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.(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
2215 IF (ILOOP.EQ.4) THEN
2216 WRITE(LOUT,1000) NEVHKK
2217 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
2222 * variable energy-runs, recalculate parameters for LT's
2223 IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2226 CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2228 IF (EPN.GT.EPROJ) THEN
2229 WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2230 & ' Requested energy (',EPN,'GeV) exceeds',
2231 & ' initialization energy (',EPROJ,'GeV) !'
2235 * re-initialize /DTPRTA/
2241 IBPROJ = IIBAR(IJPROJ)
2243 * calculate nuclear potentials (common /DTNPOT/)
2244 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2246 * initialize treatment for residual nuclei
2247 CALL DT_RESNCL(EPN,NLOOP,1)
2249 * sample hadron/nucleus-nucleus interaction
2250 CALL DT_KKEVNT(KKMAT,IREJ1)
2251 IF (IREJ1.GT.0) THEN
2252 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2256 IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2258 * intranuclear cascade of final state particles for KTAUGE generations
2260 CALL DT_FOZOCA(LFZC,IREJ1)
2261 IF (IREJ1.GT.0) THEN
2262 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2266 * baryons unable to escape the nuclear potential are treated as
2267 * excited nucleons (ISTHKK=15,16)
2270 * decay of resonances produced in intranuclear cascade processes
2271 **sr 15-11-95 should be obsolete
2272 C IF (LFZC) CALL DT_DECAY1
2275 * treatment of residual nuclei
2276 CALL DT_RESNCL(EPN,NLOOP,2)
2278 * evaporation / fission / fragmentation
2279 * (if intranuclear cascade was sampled only)
2281 CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2282 IF (IREJ1.GT.1) GOTO 101
2283 IF (IREJ1.EQ.1) GOTO 100
2288 * rejection of unphysical configurations
2289 CALL DT_REJUCO(1,IREJ1)
2290 IF (IREJ1.GT.0) THEN
2292 & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2296 * transform finale state into Lab.
2298 CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2299 IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2301 IF (IPI0.EQ.1) CALL DT_DECPI0
2303 C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2311 *$ CREATE DT_DEFAUL.FOR
2314 *===defaul=============================================================*
2316 SUBROUTINE DT_DEFAUL(EPN,PPN)
2318 ************************************************************************
2319 * Variables are set to default values. *
2320 * This version dated 8.5.95 is written by S. Roesler. *
2321 ************************************************************************
2323 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2325 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2326 PARAMETER (TWOPI = 6.283185307179586454D+00)
2328 * particle properties (BAMJET index convention)
2330 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2331 & IICH(210),IIBAR(210),K1(210),K2(210)
2334 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2335 & EBINDP(2),EBINDN(2),EPOT(2,210),
2336 & ETACOU(2),ICOUL,LFERMI
2337 * interface HADRIN-DPM
2338 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2339 * central particle production, impact parameter biasing
2340 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2341 * properties of interacting particles
2342 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2343 * properties of photon/lepton projectiles
2344 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2345 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2346 * emulsion treatment
2347 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2349 * parameter for intranuclear cascade
2351 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2352 * various options for treatment of partons (DTUNUC 1.x)
2353 * (chain recombination, Cronin,..)
2354 LOGICAL LCO2CR,LINTPT
2355 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2357 * threshold values for x-sampling (DTUNUC 1.x)
2358 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2360 * flags for input different options
2361 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2362 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2363 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2364 * n-n cross section fluctuations
2365 PARAMETER (NBINS = 1000)
2366 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2367 * flags for particle decays
2368 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2369 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2370 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2371 * diquark-breaking mechanism
2372 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2373 * nucleon-nucleon event-generator
2376 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2377 * flags for diffractive interactions (DTUNUC 1.x)
2378 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2379 * VDM parameter for photon-nucleus interactions
2380 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2381 * Glauber formalism: flags and parameters for statistics
2384 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2385 * kinematical cuts for lepton-nucleus interactions
2386 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2387 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2388 * flags for activated histograms
2389 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2390 * cuts for variable energy runs
2391 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2392 * parameters for hA-diffraction
2393 COMMON /DTDIHA/ DIBETA,DIALPH
2396 COMMON /LEPTOI/ RPPN,LEPIN,INTER
2397 * steering flags for qel neutrino scattering modules
2398 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2400 COMMON /DTEVNO/ NEVENT,ICASCA
2402 DATA POTMES /0.002D0/
2413 * nucleus independent meson potential
2461 **sr 7.4.98: changed after corrected B-sampling
2480 * definition of soft quark distributions
2485 * cutoff parameters for x-sampling
2531 CMODEL(1) = 'DTUNUC '
2532 CMODEL(2) = 'PHOJET '
2533 CMODEL(3) = 'LEPTO '
2534 CMODEL(4) = 'QNEUTRIN'
2571 IF (ITRSPT.EQ.1) THEN
2606 IF (ITRSPT.EQ.1) THEN
2612 * default Lab.-energy
2614 PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2619 *$ CREATE DT_AAEVT.FOR
2622 *===aaevt==============================================================*
2624 SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2627 ************************************************************************
2628 * This version dated 22.03.96 is written by S. Roesler. *
2629 ************************************************************************
2631 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2633 PARAMETER ( LINP = 10 ,
2637 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2638 * emulsion treatment
2639 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2642 COMMON /DTEVNO/ NEVENT,ICASCA
2643 CHARACTER*8 DATE,HHMMSS
2649 NMSG = MAX(NEVTS/100,1)
2651 * initialization of run-statistics and histograms
2653 CALL PHO_PHIST(1000,DUM)
2655 * initialization of Glauber-formalism
2656 IF (NCOMPO.LE.0) THEN
2657 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2660 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2666 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2667 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2669 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2670 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2671 WRITE(LOUT,1001) DATE,HHMMSS
2672 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2673 & ' Time: ',A8,' )')
2675 * generate NEVTS events
2678 * print run-status message
2679 IF (MOD(IEVT,NMSG).EQ.0) THEN
2681 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2682 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2684 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2685 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2686 WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2687 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2688 & ' Time: ',A,' )',/)
2689 C WRITE(LOUT,1000) IEVT-1
2690 C1000 FORMAT(1X,I8,' events sampled')
2693 * treat nuclear emulsions
2694 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2695 * composite targets only
2698 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2700 CALL PHO_PHIST(2000,DUM)
2702 write(6,*) "Diffractive collisions", NSD1, NSD2, NDD
2706 * print run-statistics and histograms to output-unit 6
2707 CALL PHO_PHIST(3000,DUM)
2712 *$ CREATE DT_LAEVT.FOR
2715 *===laevt==============================================================*
2717 SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2720 ************************************************************************
2721 * Interface to run DPMJET for lepton-nucleus interactions. *
2722 * Kinematics is sampled using the equivalent photon approximation *
2723 * Based on GPHERA-routine by R. Engel. *
2724 * This version dated 23.03.96 is written by S. Roesler. *
2725 ************************************************************************
2727 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2729 PARAMETER ( LINP = 10 ,
2732 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2733 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2734 PARAMETER (TWOPI = 6.283185307179586454D+00,
2736 & ALPHEM = ONE/137.0D0)
2738 C CHARACTER*72 HEADER
2740 * particle properties (BAMJET index convention)
2742 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2743 & IICH(210),IIBAR(210),K1(210),K2(210)
2745 PARAMETER (NMXHKK=200000)
2746 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2747 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2748 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2749 * extended event history
2750 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2751 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2753 * kinematical cuts for lepton-nucleus interactions
2754 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2755 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2756 * properties of interacting particles
2757 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2758 * properties of photon/lepton projectiles
2759 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2760 * kinematics at lepton-gamma vertex
2761 COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2762 * flags for activated histograms
2763 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2764 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2765 * emulsion treatment
2766 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2768 * Glauber formalism: cross sections
2769 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2770 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2771 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2772 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2773 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2774 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2775 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2776 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2777 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2778 & BSLOPE,NEBINI,NQBINI
2779 * nucleon-nucleon event-generator
2782 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2783 * flags for input different options
2784 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2785 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2786 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2788 COMMON /DTEVNO/ NEVENT,ICASCA
2790 DIMENSION XDUMB(40),BGTA(4)
2793 IF (MCGENE.EQ.3) THEN
2794 STOP ' This version does not contain LEPTO !'
2798 NMSG = MAX(NEVTS/10,1)
2800 * mass of incident lepton
2803 IDPPDG = IDT_IPDGHA(IDP)
2805 * consistency of kinematical limits
2806 Q2MIN = MAX(Q2MIN,TINY10)
2807 Q2MAX = MAX(Q2MAX,TINY10)
2808 YMIN = MIN(MAX(YMIN,TINY10),0.999D0)
2809 YMAX = MIN(MAX(YMAX,TINY10),0.999D0)
2811 * total energy of the lepton-nucleon system
2812 PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2813 & +(PLEPT0(3)+PNUCL(3))**2 )
2814 ETOTLN = PLEPT0(4)+PNUCL(4)
2815 ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2816 ECMAX = MIN(ECMAX,ECMLN)
2817 WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2819 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2820 & '------------------',/,9X,'W (min) =',
2821 & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =',
2822 & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2823 & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) ='
2824 & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2825 & F7.4,' for E_lpt >',F7.1,' GeV',/)
2827 * Lorentz-parameter for transf. into Lab
2828 BGTA(1) = PNUCL(1)/AAM(1)
2829 BGTA(2) = PNUCL(2)/AAM(1)
2830 BGTA(3) = PNUCL(3)/AAM(1)
2831 BGTA(4) = PNUCL(4)/AAM(1)
2832 * LT of incident lepton into Lab and dump it in DTEVT1
2833 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2834 & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2835 & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2836 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2837 & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2838 & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2839 * maximum energy of photon nucleon system
2840 PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2841 & +(YMAX*PPL0(3)+PPA(3))**2)
2842 ETOTGN = YMAX*PPL0(4)+PPA(4)
2843 EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2844 EGNMAX = MIN(EGNMAX,ECMAX)
2845 * minimum energy of photon nucleon system
2846 PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2847 & +(YMIN*PPL0(3)+PPA(3))**2)
2848 ETOTGN = YMIN*PPL0(4)+PPA(4)
2849 EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2850 EGNMIN = MAX(EGNMIN,ECMIN)
2852 * limits for Glauber-initialization
2854 Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2855 ECMLI = MAX(EGNMIN,THREE)
2857 WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2858 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1,
2859 & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ',
2860 & 'Glauber-initialization:',/,9X,'W (min) =',F7.1,
2861 & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2862 & ' GeV^2 (max) =',F7.1,' GeV^2',/)
2863 * initialization of Glauber-formalism
2864 IF (NCOMPO.LE.0) THEN
2865 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2868 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2873 * initialization of run-statistics and histograms
2875 CALL PHO_PHIST(1000,DUM)
2877 * maximum photon-nucleus cross section
2881 IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2885 ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2887 IF (EGNMAX.LT.ECMNN(I)) THEN
2890 RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2896 SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2901 IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2905 ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2907 IF (EGNMIN.LT.ECMNN(I)) THEN
2910 RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2916 SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2917 IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2918 SIGMAX = MAX(SIGMAX,SIGXX)
2919 WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2921 * plot photon flux table
2926 ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2927 C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
2929 Y = EXP(AYMIN+ADY*DBLE(I-1))
2930 Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2931 FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2932 & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2933 FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2934 & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2935 C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2938 * maximum residual weight for flux sampling (dy/y)
2940 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2941 WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2942 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2944 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2945 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2946 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2947 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2948 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2949 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
2950 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
2951 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
2952 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
2953 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
2954 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
2955 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
2957 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
2958 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
2959 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
2968 IF (MOD(IEVT,NMSG).EQ.0) THEN
2969 C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
2970 C & STATUS='UNKNOWN')
2971 WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
2982 YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
2983 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2984 Q2LOG = LOG(Q2MAX/Q2LOW)
2985 WGH = (ONE+(ONE-YY)**2)*Q2LOG
2986 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2987 IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
2988 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5)
2989 IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
2992 YEFF = ONE+(ONE-YY)**2
2994 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2995 WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
2996 IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
2999 c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3000 c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3002 * kinematics at lepton-photon vertex
3003 * scattered electron
3004 YQ2 = SQRT((ONE-YY)*Q2)
3005 Q2E = Q2/(4.0D0*PLEPT0(4))
3006 E1Y = (ONE-YY)*PLEPT0(4)
3007 CALL DT_DSFECF(SIF,COF)
3012 C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3014 PGAMM(1) = -PLEPT1(1)
3015 PGAMM(2) = -PLEPT1(2)
3016 PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3017 PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3019 PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3020 & +(PGAMM(3)+PNUCL(3))**2 )
3021 ETOTGN = PGAMM(4)+PNUCL(4)
3022 ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3023 IF (ECMGN.LT.0.1D0) GOTO 101
3025 IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3027 * Lorentz-transformation into nucleon-rest system
3028 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3029 & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3030 & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3031 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3032 & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3033 & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3034 * temporary checks..
3035 Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3036 IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3037 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ',
3039 ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3040 IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3041 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ',
3043 YYTMP = PPG(4)/PPL0(4)
3044 IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3045 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ',
3048 * lepton tagger (Lab)
3049 THETA = ACOS( PPL1(3)/PLTOT )
3050 IF (PPL1(4).GT.ELMIN) THEN
3051 IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3053 * photon energy-cut (Lab)
3054 IF (PPG(4).LT.EGMIN) GOTO 101
3055 IF (PPG(4).GT.EGMAX) GOTO 101
3057 XBJ = ABS(Q2/(1.876D0*PPG(4)))
3058 IF (XBJ.LT.XBJMIN) GOTO 101
3061 CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0)
3062 CALL DT_FILHGR( YY,ONE,IHFLY0,NC0)
3063 CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0)
3064 CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3065 CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3067 * rotation angles against z-axis
3069 C SID = SQRT((ONE-COD)*(ONE+COD))
3070 PPT = SQRT(PPG(1)**2+PPG(2)**2)
3074 IF (PGTOT*SID.GT.TINY10) THEN
3075 COF = PPG(1)/(SID*PGTOT)
3076 SIF = PPG(2)/(SID*PGTOT)
3077 ANORF = SQRT(COF*COF+SIF*SIF)
3082 IF (IXSTBL.EQ.0) THEN
3083 * change to photon projectile
3087 * re-initialize LTs with new kinematics
3088 * !!PGAMM ist set in cms (ECMGN) along z
3091 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3094 * get emulsion component if requested
3095 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3096 * convolute with cross section
3097 CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3098 CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3099 IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3100 & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3102 IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3104 CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1)
3105 CALL DT_FILHGR( YY,ONE,IHFLY1,NC1)
3106 CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1)
3107 CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3108 CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3109 * composite targets only
3112 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3114 * rotate momenta of final state particles back in photon-nucleon syst.
3115 DO 4 I=NPOINT(4),NHKK
3116 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3117 & (ISTHKK(I).EQ.1001)) THEN
3121 CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3122 & PHKK(1,I),PHKK(2,I),PHKK(3,I))
3127 CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1)
3128 CALL DT_FILHGR( YY,ONE,IHFLY2,NC1)
3129 CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1)
3130 CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3131 CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3133 * dump this event to histograms
3134 CALL PHO_PHIST(2000,DUM)
3138 WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3139 WGY = WGY*LOG(YMAX/YMIN)
3140 WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3142 C HEADER = ' LAEVT: Q^2 distribution 0'
3143 C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3144 C HEADER = ' LAEVT: Q^2 distribution 1'
3145 C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3146 C HEADER = ' LAEVT: Q^2 distribution 2'
3147 C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3148 C HEADER = ' LAEVT: y distribution 0'
3149 C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3150 C HEADER = ' LAEVT: y distribution 1'
3151 C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3152 C HEADER = ' LAEVT: y distribution 2'
3153 C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3154 C HEADER = ' LAEVT: x distribution 0'
3155 C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3156 C HEADER = ' LAEVT: x distribution 1'
3157 C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3158 C HEADER = ' LAEVT: x distribution 2'
3159 C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3160 C HEADER = ' LAEVT: E_g distribution 0'
3161 C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3162 C HEADER = ' LAEVT: E_g distribution 1'
3163 C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3164 C HEADER = ' LAEVT: E_g distribution 2'
3165 C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3166 C HEADER = ' LAEVT: E_c distribution 0'
3167 C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3168 C HEADER = ' LAEVT: E_c distribution 1'
3169 C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3170 C HEADER = ' LAEVT: E_c distribution 2'
3171 C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3173 * print run-statistics and histograms to output-unit 6
3174 CALL PHO_PHIST(3000,DUM)
3175 IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3180 *$ CREATE DT_DTUINI.FOR
3183 *===dtuini=============================================================*
3185 SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3188 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3191 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3192 * emulsion treatment
3193 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3195 * Glauber formalism: flags and parameters for statistics
3198 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3200 CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3202 CALL PHO_PHIST(1000,DUM)
3203 IF (NCOMPO.LE.0) THEN
3204 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3207 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3210 IF (IOGLB.NE.100) CALL DT_SIGEMU
3216 *$ CREATE DT_DTUOUT.FOR
3219 *===dtuout=============================================================*
3221 SUBROUTINE DT_DTUOUT
3223 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3226 CALL PHO_PHIST(3000,DUM)
3232 *$ CREATE DT_BEAMPR.FOR
3235 *===beampr=============================================================*
3237 SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3239 ************************************************************************
3240 * Initialization of event generation *
3241 * This version dated 7.4.98 is written by S. Roesler. *
3242 ************************************************************************
3244 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3247 PARAMETER ( LINP = 10 ,
3250 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3251 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3256 PARAMETER (NMXHKK=200000)
3257 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3258 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3259 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3260 * extended event history
3261 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3262 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3264 * properties of interacting particles
3265 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3266 * particle properties (BAMJET index convention)
3268 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3269 & IICH(210),IIBAR(210),K1(210),K2(210)
3271 COMMON /DTBEAM/ P1(4),P2(4)
3273 C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3274 DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3276 DATA LBEAM /.FALSE./
3283 IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3285 IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3286 PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3287 PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3288 TH = 1.D-6*WHAT(3)/2.D0
3290 P1(1) = PP1*SIN(TH)*COS(PH)
3291 P1(2) = PP1*SIN(TH)*SIN(PH)
3294 P2(1) = PP2*SIN(TH)*COS(PH)
3295 P2(2) = PP2*SIN(TH)*SIN(PH)
3296 P2(3) = -PP2*COS(TH)
3298 ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3299 & -(P1(3)+P2(3))**2 )
3300 ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3301 PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3302 BGX = (P1(1)+P2(1))/ECM
3303 BGY = (P1(2)+P2(2))/ECM
3304 BGZ = (P1(3)+P2(3))/ECM
3305 BGE = (P1(4)+P2(4))/ECM
3306 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3307 & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3308 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3309 & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3310 COD = P1CMS(3)/P1TOT
3311 C SID = SQRT((ONE-COD)*(ONE+COD))
3312 PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3316 IF (P1TOT*SID.GT.TINY10) THEN
3317 COF = P1CMS(1)/(SID*P1TOT)
3318 SIF = P1CMS(2)/(SID*P1TOT)
3319 ANORF = SQRT(COF*COF+SIF*SIF)
3324 C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3325 C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3326 C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3327 C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3331 C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3335 C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3336 C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3337 C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3338 C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3339 C & P1CMS(1),P1CMS(2),P1CMS(3))
3340 C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3341 C & P2CMS(1),P2CMS(2),P2CMS(3))
3342 C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3343 C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3344 C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3345 C & P1TOT,P1(1),P1(2),P1(3),P1(4))
3346 C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3347 C & P2TOT,P2(1),P2(2),P2(3),P2(4))
3348 C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3349 C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3360 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3361 DO 20 I=NPOINT(4),NHKK
3362 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3363 & (ISTHKK(I).EQ.1001)) THEN
3364 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3365 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3367 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3368 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3378 *$ CREATE DT_REJUCO.FOR
3381 *===rejuco=============================================================*
3383 SUBROUTINE DT_REJUCO(MODE,IREJ)
3385 ************************************************************************
3386 * REJection of Unphysical COnfigurations *
3387 * MODE = 1 rejection of particles with unphysically large energy *
3389 * This version dated 27.12.2006 is written by S. Roesler. *
3390 ************************************************************************
3392 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3395 PARAMETER ( LINP = 10 ,
3398 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3399 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3401 * maximum x_cms of final state particle
3402 PARAMETER (XCMSMX = 1.4D0)
3405 PARAMETER (NMXHKK=200000)
3406 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3407 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3408 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3409 * extended event history
3410 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3411 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3413 * Lorentz-parameters of the current interaction
3414 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3415 & UMO,PPCM,EPROJ,PPROJ
3420 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3422 DO 10 I=NPOINT(4),NHKK
3423 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3424 XCMS = ABS(PHKK(4,I))/ECMHLF
3425 IF (XCMS.GT.XCMSMX) GOTO 9999
3436 *$ CREATE DT_EVENTB.FOR
3439 *===eventb=============================================================*
3441 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3443 ************************************************************************
3444 * Treatment of nucleon-nucleon interactions with full two-component *
3445 * Dual Parton Model. *
3446 * NCSY number of nucleon-nucleon interactions *
3447 * IREJ rejection flag *
3448 * This version dated 14.01.2000 is written by S. Roesler *
3449 ************************************************************************
3451 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3453 PARAMETER ( LINP = 10 ,
3456 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3459 PARAMETER (NMXHKK=200000)
3460 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3461 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3462 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3463 * extended event history
3464 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3465 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3467 *! uncomment this line for internal phojet-fragmentation
3468 C #include "dtu_dtevtp.inc"
3469 * particle properties (BAMJET index convention)
3471 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3472 & IICH(210),IIBAR(210),K1(210),K2(210)
3473 * flags for input different options
3474 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3475 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3476 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3478 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3479 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3480 & IREXCI(3),IRDIFF(2),IRINC
3481 * properties of interacting particles
3482 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3483 * properties of photon/lepton projectiles
3484 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3485 * various options for treatment of partons (DTUNUC 1.x)
3486 * (chain recombination, Cronin,..)
3487 LOGICAL LCO2CR,LINTPT
3488 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3491 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3492 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3494 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3495 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3496 * Glauber formalism: collision properties
3497 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3498 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3499 * flags for diffractive interactions (DTUNUC 1.x)
3500 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3501 * statistics: double-Pomeron exchange
3502 COMMON /DTFLG2/ INTFLG,IPOPO
3503 * flags for particle decays
3504 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3505 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3506 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3507 * nucleon-nucleon event-generator
3510 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3511 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3512 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3513 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3514 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3515 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3516 C model switches and parameters
3518 INTEGER ISWMDL,IPAMDL
3519 DOUBLE PRECISION PARMDL
3520 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3521 C initial state parton radiation (internal part)
3522 INTEGER MXISR3,MXISR4
3523 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3524 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3525 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3526 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3527 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3528 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3529 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3530 C event debugging information
3532 PARAMETER (NMAXD=100)
3533 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3534 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3535 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3536 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3537 C general process information
3538 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3539 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3541 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3542 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3543 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3544 & KPRON(15),ISINGL(2000)
3546 * initial values for max. number of phojet scatterings and dtunuc chains
3547 * to be fragmented with one pyexec call
3548 DATA MXPHFR,MXDTFR /10,100/
3551 * pointer to first parton of the first chain in dtevt common
3553 * special flag for double-Pomeron statistics
3555 * counter for low-mass (DTUNUC) interactions
3557 * counter for interactions treated by PHOJET
3560 * scan interactions for single nucleon-nucleon interactions
3561 * (this has to be checked here because Cronin modifies parton momenta)
3563 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3567 MOT = JMOHKK(1,NC+1)
3568 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3569 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3570 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3574 * multiple scattering of chain ends
3575 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3576 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3578 * switch to PHOJET-settings for JETSET parameter
3581 * loop over nucleon-nucleon interaction
3585 * pick up one nucleon-nucleon interaction from DTEVT1
3586 * ppnn / ptnn - momenta of the interacting nucleons (cms)
3587 * ptotnn - total momentum of the interacting nucleons (cms)
3588 * pp1,2 / pt1,2 - momenta of the four partons
3589 * pp / pt - total momenta of the proj / targ partons
3590 * ptot - total momentum of the four partons
3592 MOT = JMOHKK(1,NC+1)
3594 PPNN(K) = PHKK(K,MOP)
3595 PTNN(K) = PHKK(K,MOT)
3596 PTOTNN(K) = PPNN(K)+PTNN(K)
3598 PT1(K) = PHKK(K,NC+1)
3599 PP2(K) = PHKK(K,NC+2)
3600 PT2(K) = PHKK(K,NC+3)
3601 PP(K) = PP1(K)+PP2(K)
3602 PT(K) = PT1(K)+PT2(K)
3603 PTOT(K) = PP(K)+PT(K)
3606 *-----------------------------------------------------------------------
3607 * this is a complete nucleon-nucleon interaction
3609 IF (ISINGL(I).EQ.1) THEN
3611 * initialize PHOJET-variables for remnant/valence-partons
3618 * save current settings of PHOJET process and min. bias flags
3620 KPRON(K) = IPRON(K,1)
3624 * check if forced sampling of diffractive interaction requested
3625 IF (ISINGD.LT.-1) THEN
3629 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3630 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3631 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3634 * for photons: a direct/anomalous interaction is not sampled
3635 * in PHOJET but already in Glauber-formalism. Here we check if such
3636 * an interaction is requested
3637 IF (IJPROJ.EQ.7) THEN
3638 * first switch off direct interactions
3640 * this is a direct interactions
3641 IF (IDIREC.EQ.1) THEN
3646 * this is an anomalous interactions
3647 * (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3648 ELSEIF (IDIREC.EQ.2) THEN
3652 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3655 * make sure that total momenta of partons, pp and pt, are on mass
3656 * shell (Cronin may have srewed this up..)
3657 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3659 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3660 & 'EVENTB: mass shell correction rejected'
3664 * initialize the incoming particles in PHOJET
3665 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3666 CALL PHO_SETPAR(1,22,0,VIRT)
3668 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3670 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3672 * initialize rejection loop counter for anomalous processes
3677 * temporary fix for ifano problem
3681 * generate complete hadron/nucleon/photon-nucleon event with PHOJET
3682 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3684 * for photons: special consistency check for anomalous interactions
3685 IF (IJPROJ.EQ.7) THEN
3686 IF (IRJANO.LT.30) THEN
3687 IF (IFANO(1).NE.0) THEN
3688 * here, an anomalous interaction was generated. Check if it
3689 * was also requested. Otherwise reject this event.
3690 IF (IDIREC.EQ.0) GOTO 800
3692 * here, an anomalous interaction was not generated. Check if it
3693 * was requested in which case we need to reject this event.
3694 IF (IDIREC.EQ.2) GOTO 800
3697 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3698 & IRJANO,IDIREC,NEVHKK
3702 * copy back original settings of PHOJET process and min. bias flags
3704 IPRON(K,1) = KPRON(K)
3708 * check if PHOJET has rejected this event
3709 IF (IREJ1.NE.0) THEN
3710 C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3711 WRITE(LOUT,'(1X,A,I4)')
3712 & 'EVENTB: chain system rejected',IDIREC
3717 * copy partons and strings from PHOJET common back into DTEVT for
3718 * external fragmentation
3721 *! uncomment this line for internal phojet-fragmentation
3722 C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3724 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3725 IF (IREJ1.NE.0) THEN
3727 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3731 * update statistics counter
3732 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3734 *-----------------------------------------------------------------------
3735 * this interaction involves "remnants"
3739 * total mass of this system
3740 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3741 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3742 IF (AMTOT2.LT.ZERO) THEN
3745 AMTOT = SQRT(AMTOT2)
3748 * systems with masses larger than elojet are treated with PHOJET
3749 IF (AMTOT.GT.ELOJET) THEN
3751 * initialize PHOJET-variables for remnant/valence-partons
3752 * projectile parton flavors and valence flag
3753 IHFLD(1,1) = IDHKK(NC)
3754 IHFLD(1,2) = IDHKK(NC+2)
3756 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3757 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3758 * target parton flavors and valence flag
3759 IHFLD(2,1) = IDHKK(NC+1)
3760 IHFLD(2,2) = IDHKK(NC+3)
3762 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3763 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3764 * flag signalizing PHOJET how to treat the remnant:
3765 * iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3766 * iremn > -1 valence remnant: PHOJET assumes flavors according
3767 * to mother particle
3771 * initialize the incoming particles in PHOJET
3772 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3773 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3775 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3777 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3779 * calculate Lorentz parameter of the nucleon-nucleon cm-system
3780 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3781 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3782 BGX = PTOTNN(1)/AMNN
3783 BGY = PTOTNN(2)/AMNN
3784 BGZ = PTOTNN(3)/AMNN
3785 GAM = PTOTNN(4)/AMNN
3786 * transform interacting nucleons into nucleon-nucleon cm-system
3787 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3788 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3789 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3790 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3791 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3792 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3793 * transform (total) momenta of the proj and targ partons into
3794 * nucleon-nucleon cm-system
3795 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3796 & PP(1),PP(2),PP(3),PP(4),
3797 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3798 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3799 & PT(1),PT(2),PT(3),PT(4),
3800 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3801 * energy fractions of the proj and targ partons
3802 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3803 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3806 c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3807 c & (PPTCMS(2)+PTTCMS(2))**2 +
3808 c & (PPTCMS(3)+PTTCMS(3))**2 )
3809 c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3810 c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3811 c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3812 c & (PPSUB(2)+PTSUB(2))**2 +
3813 c & (PPSUB(3)+PTSUB(3))**2 )
3814 c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3815 c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3818 * save current settings of PHOJET process and min. bias flags
3820 KPRON(K) = IPRON(K,1)
3822 * disallow direct photon int. (does not make sense here anyway)
3824 * disallow double pomeron processes (due to technical problems
3825 * in PHOJET, needs to be solved sometime)
3827 * disallow diffraction for sea-diquarks
3828 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3829 & (IABS(IHFLD(1,2)).GT.1100)) THEN
3833 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3834 & (IABS(IHFLD(2,2)).GT.1100)) THEN
3839 * we need massless partons: transform them on mass shell
3846 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3847 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3848 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3849 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3850 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3851 * total energy of the subsysten after mass transformation
3852 * (should be the same as before..)
3853 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3854 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
3856 * after mass shell transformation the x_sub - relation has to be
3857 * corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3859 * The old version was to scale based on the original x_sub and the
3860 * 4-momenta of the subsystem. At very high energy this could lead to
3861 * "pseudo-cm energies" of the parent system considerably exceeding
3862 * the true cm energy. Now we keep the true cm energy and calculate
3863 * new x_sub instead.
3864 C old version PPTCMS(4) = PPSUB(4)/XPSUB
3865 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3866 XPSUB = PPSUB(4)/PPTCMS(4)
3867 IF (IJPROJ.EQ.7) THEN
3868 AMP2 = PHKK(5,MOT)**2
3869 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3872 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3873 & *(PPTCMS(4)+PHKK(5,MOP)))
3874 C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3875 C & *(PPTCMS(4)+PHKK(5,MOT)))
3877 C old version PTTCMS(4) = PTSUB(4)/XTSUB
3878 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3879 XTSUB = PTSUB(4)/PTTCMS(4)
3880 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3881 & *(PTTCMS(4)+PHKK(5,MOT)))
3883 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3884 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3889 * ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
3890 * ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
3891 * pptcms/ pttcms - momenta of the interacting nucleons (cms)
3892 * pp1,2 / pt1,2 - momenta of the four partons
3894 * pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
3895 * ptot - total momentum of the four partons (cms, negl. Fermi)
3896 * ppsub / ptsub - total momenta of the proj / targ partons (cms)
3898 c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3899 c & (PPTCMS(2)+PTTCMS(2))**2 +
3900 c & (PPTCMS(3)+PTTCMS(3))**2 )
3901 c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3902 c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3903 c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3904 c & (PPSUB(2)+PTSUB(2))**2 +
3905 c & (PPSUB(3)+PTSUB(3))**2 )
3906 c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3907 c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3908 c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3909 c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3910 c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3911 c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
3913 c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3914 c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3915 c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3916 c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3917 * transform interacting nucleons into nucleon-nucleon cm-system
3918 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3919 c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3920 c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3921 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3922 c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3923 c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3924 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3925 c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3926 c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3927 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3928 c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3929 c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3930 c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3931 c & (PPNEW2+PTNEW2)**2 +
3932 c & (PPNEW3+PTNEW3)**2 )
3933 c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3934 c & (PPNEW4+PTNEW4+PTSTCM) )
3935 c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3936 c & (PPSUB2+PTSUB2)**2 +
3937 c & (PPSUB3+PTSUB3)**2 )
3938 c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3939 c & (PPSUB4+PTSUB4+PTSTSU) )
3940 C WRITE(*,*) ' mother cmE :'
3941 C WRITE(*,*) ETSTCM,ENEWCM
3942 C WRITE(*,*) ' subsystem cmE :'
3943 C WRITE(*,*) ETSTSU,ENEWSU
3944 C WRITE(*,*) ' projectile mother :'
3945 C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3946 C WRITE(*,*) ' target mother :'
3947 C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3948 C WRITE(*,*) ' projectile subsystem:'
3949 C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3950 C WRITE(*,*) ' target subsystem:'
3951 C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3952 C WRITE(*,*) ' projectile subsystem should be:'
3953 C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3954 C & XPSUB*ETSTCM/2.0D0
3955 C WRITE(*,*) ' target subsystem should be:'
3956 C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3957 C & XTSUB*ETSTCM/2.0D0
3958 C WRITE(*,*) ' subsystem cmE should be: '
3959 C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3962 * generate complete remnant - nucleon/remnant event with PHOJET
3963 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3965 * copy back original settings of PHOJET process flags
3967 IPRON(K,1) = KPRON(K)
3970 * check if PHOJET has rejected this event
3971 IF (IREJ1.NE.0) THEN
3973 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
3975 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3980 * copy partons and strings from PHOJET common back into DTEVT for
3981 * external fragmentation
3984 *! uncomment this line for internal phojet-fragmentation
3985 C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3987 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3988 IF (IREJ1.NE.0) THEN
3989 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3990 & 'EVENTB: chain system rejected 2'
3994 * update statistics counter
3995 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
3997 *-----------------------------------------------------------------------
3998 * two-chain approx. for smaller systems
4003 * special flag for double-Pomeron statistics
4006 * pick up flavors at the ends of the two chains
4011 * ..and the indices of the mothers
4016 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4017 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4019 * check if this chain system was rejected
4020 IF (IREJ1.GT.0) THEN
4021 IF (IOULEV(1).GT.0) THEN
4022 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4023 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4024 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4029 * the following lines are for sea-sea chains rejected in GETCSY
4030 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4031 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4036 * update statistics counter
4037 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4043 *-----------------------------------------------------------------------
4044 * treatment of low-mass chains (if there are any)
4046 IF (NDTUSC.GT.0) THEN
4048 * correct chains of very low masses for possible resonances
4049 IF (IRESCO.EQ.1) THEN
4050 CALL DT_EVTRES(IREJ1)
4051 IF (IREJ1.GT.0) THEN
4052 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4053 IRRES(1) = IRRES(1)+1
4057 * fragmentation of low-mass chains
4058 *! uncomment this line for internal phojet-fragmentation
4059 * (of course it will still be fragmented by DPMJET-routines but it
4060 * has to be done here instead of further below)
4061 C CALL DT_EVTFRA(IREJ1)
4062 C IF (IREJ1.GT.0) THEN
4063 C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4068 *! uncomment this line for internal phojet-fragmentation
4069 C NPOINT(4) = NHKK+1
4070 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4073 *-----------------------------------------------------------------------
4074 * new di-quark breaking mechanisms
4078 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4079 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4084 *-----------------------------------------------------------------------
4085 * hadronize this event
4087 * hadronize PHOJET chain systems
4089 NPJE = NPHOSC/MXPHFR
4090 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4092 NLEFT = NPHOSC-NPJE*MXPHFR
4095 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4096 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4097 IF (IREJ1.GT.0) GOTO 22
4100 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4101 IF (IREJ1.GT.0) GOTO 22
4103 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4105 IF (NLEFT.GT.0) THEN
4106 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4107 IF (IREJ1.GT.0) GOTO 22
4108 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4111 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4112 IF (IREJ1.GT.0) GOTO 22
4113 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4116 * check max. filling level of jetset common and
4117 * reduce mxphfr if necessary
4118 IF (NPYMAX.GT.3000) THEN
4119 IF (NPYMAX.GT.3500) THEN
4120 MXPHFR = MAX(1,MXPHFR-2)
4122 MXPHFR = MAX(1,MXPHFR-1)
4124 C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4127 * hadronize DTUNUC chain systems
4130 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4131 IF (IREJ2.GT.0) GOTO 22
4133 * check max. filling level of jetset common and
4134 * reduce mxdtfr if necessary
4135 IF (NPYMEM.GT.3000) THEN
4136 IF (NPYMEM.GT.3500) THEN
4137 MXDTFR = MAX(1,MXDTFR-20)
4139 MXDTFR = MAX(1,MXDTFR-10)
4141 C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4144 IF (IBACK.EQ.-1) GOTO 23
4147 C CALL DT_EVTFRG(1,IREJ1)
4148 C CALL DT_EVTFRG(2,IREJ2)
4149 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4150 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4155 * get final state particles from /DTEVTP/
4156 *! uncomment this line for internal phojet-fragmentation
4157 C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4160 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4161 C IF (IREJ3.NE.0) GOTO 9999
4171 *$ CREATE DT_GETPJE.FOR
4174 *===getpje=============================================================*
4176 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4178 ************************************************************************
4179 * This subroutine copies PHOJET partons and strings from POEVT1 into *
4181 * MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4182 * PP,PT 4-momenta of projectile/target being handled by *
4184 * This version dated 11.12.99 is written by S. Roesler *
4185 ************************************************************************
4187 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4189 PARAMETER ( LINP = 10 ,
4192 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4193 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4198 PARAMETER (NMXHKK=200000)
4199 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4200 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4201 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4202 * extended event history
4203 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4204 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4206 * Lorentz-parameters of the current interaction
4207 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4208 & UMO,PPCM,EPROJ,PPROJ
4209 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4210 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4211 * flags for input different options
4212 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4213 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4214 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4215 * statistics: double-Pomeron exchange
4216 COMMON /DTFLG2/ INTFLG,IPOPO
4218 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4219 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4222 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4223 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4224 & IREXCI(3),IRDIFF(2),IRINC
4225 C standard particle data interface
4227 PARAMETER (NMXHEP=4000)
4228 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4229 DOUBLE PRECISION PHEP,VHEP
4230 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4231 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4232 & VHEP(4,NMXHEP), NSD1, NSD2, NDD
4233 C extension to standard particle data interface (PHOJET specific)
4234 INTEGER IMPART,IPHIST,ICOLOR
4235 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4236 C color string configurations including collapsed strings and hadrons
4238 PARAMETER (MSTR=500)
4239 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4240 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4241 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4242 & NNCH(MSTR),IBHAD(MSTR),ISTR
4243 C general process information
4244 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4245 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4246 C model switches and parameters
4248 INTEGER ISWMDL,IPAMDL
4249 DOUBLE PRECISION PARMDL
4250 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4251 C event debugging information
4253 PARAMETER (NMAXD=100)
4254 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4255 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4256 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4257 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4259 DIMENSION PP(4),PT(4)
4269 * store initial momenta for energy-momentum conservation check
4271 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4272 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4274 * copy partons and strings from POEVT1 into DTEVT1
4276 C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4277 IF (NCODE(I).EQ.-99) THEN
4279 IDSTG = IDHEP(IDXSTG)
4286 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4293 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4296 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4299 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4306 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4310 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4312 ELSEIF (NCODE(I).GE.0) THEN
4313 * indices of partons and string in POEVT1
4314 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4315 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4316 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4317 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4318 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4322 * find "mother" string of the string
4323 IDXMS1 = ABS(JMOHEP(1,IDX1))
4324 IDXMS2 = ABS(JMOHEP(1,IDX2))
4325 IF (IDXMS1.NE.IDXMS2) THEN
4328 C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4330 * search POEVT1 for the original hadron of the parton
4335 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4336 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4337 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4338 & (ILOOP.LT.MAXLOP)) GOTO 14
4339 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4344 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4345 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4346 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4348 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4350 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4351 & (ILOOP.LT.MAXLOP)) GOTO 15
4352 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4354 IF (IDXMS1.EQ.1) THEN
4355 ISPTN1 = ISTHKK(MO1)
4359 ISPTN1 = ISTHKK(MO2)
4364 IF (IDXMS2.EQ.1) THEN
4365 ISPTN2 = ISTHKK(MO1)
4369 ISPTN2 = ISTHKK(MO2)
4373 * check for mis-identified mothers and switch mother indices if necessary
4374 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4375 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4377 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4378 ISPTN1 = ISTHKK(MO1)
4381 ISPTN2 = ISTHKK(MO2)
4385 ISPTN1 = ISTHKK(MO2)
4388 ISPTN2 = ISTHKK(MO1)
4393 * register partons in temporary common
4394 * parton at chain end
4399 * flag only partons coming from Pomeron with 41/42
4400 C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4401 IF (IPOM1.NE.0) THEN
4402 ISTX = ABS(ISPTN1)/10
4403 IMO = ABS(ISPTN1)-10*ISTX
4406 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4407 ISTX = ABS(ISPTN1)/10
4408 IMO = ABS(ISPTN1)-10*ISTX
4409 IF ((IDHEP(IDX1).EQ.21).OR.
4410 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4417 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4418 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4420 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4423 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4425 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4428 IHIST(1,NHKK) = IPHIST(1,IDX1)
4431 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4432 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4434 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4435 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4438 NGLUON = IDX2-IDX1-1
4439 IF (NGLUON.GT.0) THEN
4440 DO 17 IGLUON=1,NGLUON
4442 IDXMS = ABS(JMOHEP(1,IDX))
4443 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4447 IDXMS = ABS(JMOHEP(1,IDXMS))
4448 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4449 & (ILOOP.LT.MAXLOP)) GOTO 16
4450 IF (ILOOP.EQ.MAXLOP)
4451 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4453 IF (IDXMS.EQ.1) THEN
4466 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4467 ISTX = ABS(ISPTN)/10
4468 IMO = ABS(ISPTN)-10*ISTX
4469 IF ((IDHEP(IDX).EQ.21).OR.
4470 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4476 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4477 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4479 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4480 & PX,PY,PZ,PE,0,0,0)
4482 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4484 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4485 & PPX,PPY,PPZ,PPE,0,0,0)
4487 IHIST(1,NHKK) = IPHIST(1,IDX)
4490 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4491 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4493 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4494 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4497 * parton at chain end
4502 * flag only partons coming from Pomeron with 41/42
4503 C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4504 IF (IPOM2.NE.0) THEN
4505 ISTX = ABS(ISPTN2)/10
4506 IMO = ABS(ISPTN2)-10*ISTX
4509 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4510 ISTX = ABS(ISPTN2)/10
4511 IMO = ABS(ISPTN2)-10*ISTX
4512 IF ((IDHEP(IDX2).EQ.21).OR.
4513 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4520 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4521 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4523 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4524 & PX,PY,PZ,PE,0,0,0)
4526 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4528 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4529 & PPX,PPY,PPZ,PPE,0,0,0)
4531 IHIST(1,NHKK) = IPHIST(1,IDX2)
4534 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4535 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4537 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4538 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4541 JSTRG = 100*IPROCE+NCODE(I)
4548 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4549 & PX,PY,PZ,PE,0,0,0)
4555 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4558 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4561 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4562 & PPX,PPY,PPZ,PPE,0,0,0)
4568 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4575 VHKK(KK,NHKK) = VHKK(KK,MO2)
4576 WHKK(KK,NHKK) = WHKK(KK,MO1)
4578 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4579 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4583 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4590 IF (UMO.GT.1.0D5) THEN
4595 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4596 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4599 * internal statistics
4600 * dble-Po statistics.
4601 IF (IPROCE.NE.4) IPOPO = 0
4605 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4606 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4608 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4609 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4610 & ') at evt(chain) ',I6,'(',I2,')')
4612 IF (IPROCE.EQ.5) THEN
4613 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4614 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4616 C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4617 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4618 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4620 ELSEIF (IPROCE.EQ.6) THEN
4621 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4622 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4624 C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4626 ELSEIF (IPROCE.EQ.7) THEN
4627 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4628 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4629 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4630 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4631 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4632 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4633 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4634 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4635 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4636 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4638 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4641 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4643 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4644 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4645 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4647 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4648 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4649 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4650 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4651 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4660 *$ CREATE DT_PHOINI.FOR
4663 *===phoini=============================================================*
4665 SUBROUTINE DT_PHOINI
4667 ************************************************************************
4668 * Initialization PHOJET-event generator for nucleon-nucleon interact. *
4669 * This version dated 16.11.95 is written by S. Roesler *
4671 * Last change 27.12.2006 by S. Roesler. *
4672 ************************************************************************
4674 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4676 PARAMETER ( LINP = 10 ,
4679 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4681 * nucleon-nucleon event-generator
4684 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4685 * particle properties (BAMJET index convention)
4687 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4688 & IICH(210),IIBAR(210),K1(210),K2(210)
4689 * Lorentz-parameters of the current interaction
4690 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4691 & UMO,PPCM,EPROJ,PPROJ
4692 * properties of interacting particles
4693 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4694 * properties of photon/lepton projectiles
4695 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4696 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4697 * emulsion treatment
4698 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4700 * VDM parameter for photon-nucleus interactions
4701 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4704 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4705 & EBINDP(2),EBINDN(2),EPOT(2,210),
4706 & ETACOU(2),ICOUL,LFERMI
4707 * Glauber formalism: flags and parameters for statistics
4710 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4712 * parameters for cascade calculations:
4713 * maximum mumber of PDF's which can be defined in phojet (limited
4714 * by the dimension of ipdfs in pho_setpdf)
4715 PARAMETER (MAXPDF = 20)
4716 * PDF parametrization and number of set for the first 30 hadrons in
4717 * the bamjet-code list
4718 * negative numbers mean that the PDF is set in phojet,
4719 * zero stands for "not a hadron"
4720 DIMENSION IPARPD(30),ISETPD(30)
4721 * PDF parametrization
4723 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4724 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4727 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4728 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4731 C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4732 C PARAMETER ( MAXPRO = 16 )
4733 C PARAMETER ( MAXTAB = 20 )
4734 C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4735 C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4737 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4738 C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4740 C global event kinematics and particle IDs
4742 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4743 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4744 C hard cross sections and MC selection weights
4746 PARAMETER ( Max_pro_2 = 16 )
4747 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4749 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4750 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4751 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4752 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4753 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4754 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4755 C model switches and parameters
4757 INTEGER ISWMDL,IPAMDL
4758 DOUBLE PRECISION PARMDL
4759 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4760 C general process information
4761 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4762 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4764 DIMENSION PP(4),PT(4)
4767 DATA LSTART /.TRUE./
4772 * lepton-projectiles: initialize real photon instead
4773 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4777 IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4778 * switch Reggeon off
4781 IFPAP(1) = IDT_IPDGHA(IJP)
4785 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4787 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4788 PVIRT(1) = PMASS(1)**2
4790 IFPAP(2) = IDT_IPDGHA(IJT)
4794 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4796 PMASS(2) = AAM(IFPAB(2))
4802 * get max. possible momenta of incoming particles to be used for PHOJET ini.
4806 IF (UMO.GE.1.E5) THEN
4809 IF (NCOMPO.GT.0) THEN
4812 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4814 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4816 PPFTMP = MAX(PFERMP(1),PFERMN(1))
4817 PTFTMP = MAX(PFERMP(2),PFERMN(2))
4818 IF (PPFTMP.GT.PPF) PPF = PPFTMP
4819 IF (PTFTMP.GT.PTF) PTF = PTFTMP
4822 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4823 PPF = MAX(PFERMP(1),PFERMN(1))
4824 PTF = MAX(PFERMP(2),PFERMN(2))
4830 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4832 PP(4) = SQRT(AMP2+PP(3)**2)
4834 EPF = SQRT(PPF**2+PMASS(1)**2)
4835 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4837 ETF = SQRT(PTF**2+PMASS(2)**2)
4838 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4839 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4840 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4842 WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4844 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
4845 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4846 IF (NCOMPO.GT.0) THEN
4847 WRITE(LOUT,1002) SCPF,PTF,PT
4849 WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4852 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
4853 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4855 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
4856 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4857 WRITE(LOUT,1004) ECMINI
4858 1004 FORMAT(' E_cm = ',E10.3)
4859 IF (IJP.EQ.8) WRITE(LOUT,1005)
4861 & ' DT_PHOINI: warning! proton parameters used for neutron',
4865 * switch off new diffractive cross sections at low energies for nuclei
4866 * (temporary solution)
4867 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4868 WRITE(LOUT,'(1X,A)')
4869 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4870 CALL PHO_SETMDL(30,0,1)
4873 C IF (IJP.EQ.7) THEN
4874 C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4876 C PP(4) = SQRT(AMP2+PP(3)**2)
4879 C IF (IP.GT.1) PFERMX = 0.5D0
4880 C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4881 C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4884 C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4885 C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4886 C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4889 IF ((ISHAD(2).EQ.1).AND.
4890 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4891 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4893 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4898 * patch for cascade calculations:
4899 * define parton distribution functions for other hadrons, i.e. other
4900 * then defined already in phojet
4901 IF (IOGLB.EQ.100) THEN
4903 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4904 & ' assiged (ID,IPAR,ISET)',/)
4907 IF (IPARPD(I).NE.0) THEN
4909 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4910 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4911 IDPDG = IDT_IPDGHA(I)
4914 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4915 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4921 C CALL PHO_PHIST(-1,SIGMAX)
4922 IF (IREJ1.NE.0) THEN
4924 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
4931 *$ CREATE DT_EVENTD.FOR
4934 *===eventd=============================================================*
4936 SUBROUTINE DT_EVENTD(IREJ)
4938 ************************************************************************
4939 * Quasi-elastic neutrino nucleus scattering. *
4940 * This version dated 29.04.00 is written by S. Roesler. *
4941 ************************************************************************
4943 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4945 PARAMETER ( LINP = 10 ,
4948 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4949 PARAMETER (SQTINF=1.0D+15)
4954 PARAMETER (NMXHKK=200000)
4955 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4956 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4957 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4958 * extended event history
4959 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4960 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4962 * flags for input different options
4963 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4964 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4965 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4966 PARAMETER (MAXLND=4000)
4967 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4968 * properties of interacting particles
4969 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4970 * Lorentz-parameters of the current interaction
4971 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4972 & UMO,PPCM,EPROJ,PPROJ
4975 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4976 & EBINDP(2),EBINDN(2),EPOT(2,210),
4977 & ETACOU(2),ICOUL,LFERMI
4978 * steering flags for qel neutrino scattering modules
4979 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4980 COMMON /QNPOL/ POLARX(4),PMODUL
4983 DATA LFIRST /.TRUE./
4995 * interacting target nucleon
4997 IF (NEUDEC.LE.9) THEN
4998 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5006 RTYP = DT_RNDM(RTYP)
5007 ZFRAC = DBLE(ITZ)/DBLE(IT)
5008 IF (RTYP.LE.ZFRAC) THEN
5017 * select first nucleon in list with matching id and reset all other
5018 * nucleons which have been marked as "wounded" by ININUC
5021 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5026 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5030 & STOP ' EVENTD: interacting target nucleon not found! '
5032 * correct position of proj. lepton: assume position of target nucleon
5034 VHKK(I,1) = VHKK(I,IDX)
5035 WHKK(I,1) = WHKK(I,IDX)
5038 * load initial momenta for conservation check
5040 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5041 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5045 * quasi-elastic scattering
5046 IF (NEUDEC.LT.9) THEN
5047 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5048 & PHKK(4,IDX),PHKK(5,IDX))
5049 * CC event on p or n
5050 ELSEIF (NEUDEC.EQ.10) THEN
5051 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5052 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5053 * NC event on p or n
5054 ELSEIF (NEUDEC.EQ.11) THEN
5055 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5056 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5059 * get final state particles from Lund-common and write them into HKKEVT
5065 IF (K(I,1).EQ.1) THEN
5071 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5072 IDBJ = IDT_ICIHAD(ID)
5073 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5074 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5075 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5077 VHKK(1,NHKK) = VHKK(1,IDX)
5078 VHKK(2,NHKK) = VHKK(2,IDX)
5079 VHKK(3,NHKK) = VHKK(3,IDX)
5080 VHKK(4,NHKK) = VHKK(4,IDX)
5082 C WHKK(1,NHKK) = POLARX(1)
5083 C WHKK(2,NHKK) = POLARX(2)
5084 C WHKK(3,NHKK) = POLARX(3)
5085 C WHKK(4,NHKK) = POLARX(4)
5087 WHKK(1,NHKK) = WHKK(1,IDX)
5088 WHKK(2,NHKK) = WHKK(2,IDX)
5089 WHKK(3,NHKK) = WHKK(3,IDX)
5090 WHKK(4,NHKK) = WHKK(4,IDX)
5092 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5098 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5099 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5102 * transform momenta into cms (as required for inc etc.)
5104 IF (ISTHKK(I).EQ.1) THEN
5105 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5114 *$ CREATE DT_KKEVNT.FOR
5117 *===kkevnt=============================================================*
5119 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5121 ************************************************************************
5122 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5123 * without nuclear effects (one event). *
5124 * This subroutine is an update of the previous version (KKEVT) written *
5125 * by J. Ranft/ H.-J. Moehring. *
5126 * This version dated 20.04.95 is written by S. Roesler *
5127 ************************************************************************
5129 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5131 PARAMETER ( LINP = 10 ,
5134 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5136 PARAMETER ( MAXNCL = 260,
5138 & MAXSQU = 20*MAXVQU,
5139 & MAXINT = MAXVQU+MAXSQU)
5141 PARAMETER (NMXHKK=200000)
5142 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5143 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5144 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5145 * extended event history
5146 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5147 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5149 * flags for input different options
5150 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5151 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5152 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5154 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5155 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5156 & IREXCI(3),IRDIFF(2),IRINC
5158 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5159 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5161 * properties of interacting particles
5162 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5163 * Lorentz-parameters of the current interaction
5164 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5165 & UMO,PPCM,EPROJ,PPROJ
5166 * flags for diffractive interactions (DTUNUC 1.x)
5167 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5168 * interface HADRIN-DPM
5169 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5170 * nucleon-nucleon event-generator
5173 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5174 * coordinates of nucleons
5175 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5176 * interface between Glauber formalism and DPM
5177 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5178 & INTER1(MAXINT),INTER2(MAXINT)
5179 * Glauber formalism: collision properties
5180 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5181 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5183 * central particle production, impact parameter biasing
5184 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5186 * statistics: Glauber-formalism
5187 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5190 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5201 IF (MOD(NC,10).EQ.0) THEN
5202 WRITE(LOUT,1000) NEVHKK
5203 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5207 * initialize DTEVT1/DTEVT2
5210 * We need the following only in order to sample nucleon coordinates.
5211 * However we don't have parameters (cross sections, slope etc.)
5212 * for neutrinos available. Therefore switch projectile to proton
5214 IF (MCGENE.EQ.4) THEN
5221 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5222 * make sure that Glauber-formalism is called each time the interaction
5223 * configuration changed
5224 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5225 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5226 * sample number of nucleon-nucleon coll. according to Glauber-form.
5227 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5238 * WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5242 * WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5246 * force diffractive particle production in h-K interactions
5247 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5248 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5253 * check number of involved proj. nucl. (NP) if central prod.is requested
5254 IF (ICENTR.GT.0) THEN
5255 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5256 IF (IBACK.GT.0) GOTO 10
5259 * get initial nucleon-configuration in projectile and target
5260 * rest-system (including Fermi-momenta if requested)
5261 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5263 IF (EPROJ.LE.EHADTH) MODE = 3
5264 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5266 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5268 * activate HADRIN at low energies (implemented for h-N scattering only)
5269 IF (EPROJ.LE.EHADHI) THEN
5270 IF (EHADTH.LT.ZERO) THEN
5271 * smooth transition btwn. DPM and HADRIN
5272 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5274 IF (RR.GT.FRAC) THEN
5276 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5277 IF (IREJ1.GT.0) GOTO 1
5280 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5284 * fixed threshold for onset of production via HADRIN
5285 IF (EPROJ.LE.EHADTH) THEN
5287 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5288 IF (IREJ1.GT.0) GOTO 1
5291 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5296 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5297 & I3,') with target (m=',I3,')',/,11X,
5298 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5299 & 'GeV) cannot be handled')
5301 * sampling of momentum-x fractions & flavors of chain ends
5304 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5307 * collect momenta of chain ends and put them into DTEVT1
5308 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5309 IF (IREJ1.NE.0) GOTO 1
5313 * handle chains including fragmentation (two-chain approximation)
5314 IF (MCGENE.EQ.1) THEN
5315 * two-chain approximation
5316 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5317 IF (IREJ1.NE.0) THEN
5318 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5321 ELSEIF (MCGENE.EQ.2) THEN
5322 * multiple-Po exchange including minijets
5323 CALL DT_EVENTB(NCSY,IREJ1)
5324 IF (IREJ1.NE.0) THEN
5325 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5328 ELSEIF (MCGENE.EQ.3) THEN
5329 STOP ' This version does not contain LEPTO !'
5330 ELSEIF (MCGENE.EQ.4) THEN
5331 * quasi-elastic neutrino scattering
5332 CALL DT_EVENTD(IREJ1)
5333 IF (IREJ1.NE.0) THEN
5334 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5338 WRITE(LOUT,1002) MCGENE
5339 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5340 & ' not available - program stopped')
5351 *$ CREATE DT_CHKCEN.FOR
5354 *===chkcen=============================================================*
5356 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5358 ************************************************************************
5359 * Check of number of involved projectile nucleons if central production*
5361 * Adopted from a part of the old KKEVT routine which was written by *
5362 * J. Ranft/H.-J.Moehring. *
5363 * This version dated 13.01.95 is written by S. Roesler *
5364 ************************************************************************
5366 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5368 PARAMETER ( LINP = 10 ,
5373 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5374 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5376 * central particle production, impact parameter biasing
5377 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5382 IF (ICENTR.EQ.2) THEN
5385 IF (NP.LT.IP-1) IBACK = 1
5386 ELSEIF (IP.LE.16) THEN
5387 IF (NP.LT.IP-2) IBACK = 1
5388 ELSEIF (IP.LE.32) THEN
5389 IF (NP.LT.IP-3) IBACK = 1
5390 ELSEIF (IP.GE.33) THEN
5391 IF (NP.LT.IP-5) IBACK = 1
5393 ELSEIF (IP.EQ.IT) THEN
5395 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5397 IF (NP.LT.IP-IP/8) IBACK = 1
5399 ELSEIF (ABS(IP-IT).LT.3) THEN
5400 IF (NP.LT.IP-IP/8) IBACK = 1
5403 * new version (DPMJET, 5.6.99)
5406 IF (NP.LT.IP-1) IBACK = 1
5407 ELSEIF (IP.LE.16) THEN
5408 IF (NP.LT.IP-2) IBACK = 1
5409 ELSEIF (IP.LT.32) THEN
5410 IF (NP.LT.IP-3) IBACK = 1
5411 ELSEIF (IP.GE.32) THEN
5414 IF (NP.LT.IP-1) IBACK = 1
5417 IF (NP.LT.IP) IBACK = 1
5420 ELSEIF (IP.EQ.IT) THEN
5423 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5426 IF (NP.LT.IP-IP/4) IBACK = 1
5428 ELSEIF (ABS(IP-IT).LT.3) THEN
5429 IF (NP.LT.IP-IP/8) IBACK = 1
5438 *$ CREATE DT_ININUC.FOR
5441 *===ininuc=============================================================*
5443 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5445 ************************************************************************
5446 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5447 * including Fermi-momenta (if reqested). *
5448 * ID BAMJET-code for hadrons (instead of nuclei) *
5449 * NMASS mass number of nucleus (number of nucleons) *
5450 * NCH charge of nucleus *
5451 * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5452 * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5453 * IMODE = 1 projectile nucleus *
5454 * = 2 target nucleus *
5455 * = 3 target nucleus (E_lab<E_thr for HADRIN) *
5456 * Adopted from a part of the old KKEVT routine which was written by *
5457 * J. Ranft/H.-J.Moehring. *
5458 * This version dated 13.01.95 is written by S. Roesler *
5459 ************************************************************************
5461 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5463 PARAMETER ( LINP = 10 ,
5466 PARAMETER (FM2MM=1.0D-12)
5468 PARAMETER ( MAXNCL = 260,
5470 & MAXSQU = 20*MAXVQU,
5471 & MAXINT = MAXVQU+MAXSQU)
5473 PARAMETER (NMXHKK=200000)
5474 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5475 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5476 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5477 * extended event history
5478 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5479 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5481 * flags for input different options
5482 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5483 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5484 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5485 * auxiliary common for chain system storage (DTUNUC 1.x)
5486 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5489 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5490 & EBINDP(2),EBINDN(2),EPOT(2,210),
5491 & ETACOU(2),ICOUL,LFERMI
5492 * properties of photon/lepton projectiles
5493 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5494 * particle properties (BAMJET index convention)
5496 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5497 & IICH(210),IIBAR(210),K1(210),K2(210)
5498 * Glauber formalism: collision properties
5499 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5500 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5501 * flavors of partons (DTUNUC 1.x)
5502 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5503 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5504 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5505 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5506 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5507 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5508 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5509 * interface HADRIN-DPM
5510 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5512 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5514 * number of neutrons
5523 IF (IMODE.GT.2) MODE = 2
5524 **sr 29.5. new NPOINT(1)-definition
5525 C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5530 * get initial configuration
5533 IF (JS(I).GT.0) THEN
5534 ISTHKK(NHKK) = 10+MODE
5535 IF (IMODE.EQ.3) THEN
5536 * additional treatment if HADRIN-generator is requested
5538 IF (NHADRI.EQ.1) IDXTA = NHKK
5539 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5542 ISTHKK(NHKK) = 12+MODE
5544 IF (NMASS.GE.2) THEN
5545 * treatment for nuclei
5546 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5548 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5551 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5554 ELSEIF (NN.LT.NNEU) THEN
5557 ELSEIF (NP.LT.NCH) THEN
5561 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5572 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5575 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5577 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5579 PFTOT(K) = PFTOT(K)+PF(K)
5580 PHKK(K,NHKK) = PF(K)
5582 PHKK(5,NHKK) = AAM(IDX)
5584 * treatment for hadrons
5585 IDHKK(NHKK) = IDT_IPDGHA(ID)
5587 PHKK(4,NHKK) = AAM(ID)
5588 PHKK(5,NHKK) = AAM(ID)
5590 C IF (IDHKK(NHKK).EQ.22) THEN
5591 C PHKK(4,NHKK) = AAM(33)
5592 C PHKK(5,NHKK) = AAM(33)
5597 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5604 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5605 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5607 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5608 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5609 VHKK(4,NHKK) = 0.0D0
5610 WHKK(4,NHKK) = 0.0D0
5613 * balance Fermi-momenta
5614 IF (NMASS.GE.2) THEN
5618 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5620 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5621 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5628 *$ CREATE DT_FER4M.FOR
5631 *===fer4m==============================================================*
5633 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5635 ************************************************************************
5636 * Sampling of nucleon Fermi-momenta from distributions at T=0. *
5637 * processed by S. Roesler, 17.10.95 *
5638 ************************************************************************
5640 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5642 PARAMETER ( LINP = 10 ,
5648 * particle properties (BAMJET index convention)
5650 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5651 & IICH(210),IIBAR(210),K1(210),K2(210)
5654 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5655 & EBINDP(2),EBINDN(2),EPOT(2,210),
5656 & ETACOU(2),ICOUL,LFERMI
5658 DATA LSTART /.TRUE./
5664 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
5668 CALL DT_DFERMI(PABS)
5670 C IF (PABS.GE.PBIND) THEN
5672 C IF (MOD(ILOOP,500).EQ.0) THEN
5673 C WRITE(LOUT,1001) PABS,PBIND,ILOOP
5674 C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
5675 C & ' energy ',2E12.3,I6)
5679 CALL DT_DPOLI(POLC,POLS)
5680 CALL DT_DSFECF(SFE,CFE)
5684 ET = SQRT(PABS*PABS+AAM(KT)**2)
5698 *$ CREATE DT_NUC2CM.FOR
5701 *===nuc2cm=============================================================*
5703 SUBROUTINE DT_NUC2CM
5705 ************************************************************************
5706 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
5707 * nucl. cms. (This subroutine replaces NUCMOM.) *
5708 * This version dated 15.01.95 is written by S. Roesler *
5709 ************************************************************************
5711 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5713 PARAMETER ( LINP = 10 ,
5716 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5719 PARAMETER (NMXHKK=200000)
5720 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5721 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5722 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5723 * extended event history
5724 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5725 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5728 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5729 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5731 * properties of photon/lepton projectiles
5732 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5733 * particle properties (BAMJET index convention)
5735 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5736 & IICH(210),IIBAR(210),K1(210),K2(210)
5737 * Glauber formalism: collision properties
5738 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5739 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5741 * statistics: Glauber-formalism
5742 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5754 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5755 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5756 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5758 C IF (IDHKK(I).EQ.22) THEN
5766 C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5767 C & PX,PY,PZ,PE,IDB,MODE)
5768 IF (PHKK(5,I).GT.ZERO) THEN
5769 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5770 & PX,PY,PZ,PE,IDBAM(I),MODE)
5780 C IF (ID.EQ.22) ID = 113
5781 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5782 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5783 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5787 NWTACC = MAX(NWAACC,NWBACC)
5791 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5799 *$ CREATE DT_SPLPTN.FOR
5802 *===splptn=============================================================*
5804 SUBROUTINE DT_SPLPTN(NN)
5806 ************************************************************************
5807 * SamPLing of ParToN momenta and flavors. *
5808 * This version dated 15.01.95 is written by S. Roesler *
5809 ************************************************************************
5811 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5813 PARAMETER ( LINP = 10 ,
5817 * Lorentz-parameters of the current interaction
5818 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5819 & UMO,PPCM,EPROJ,PPROJ
5821 * sample flavors of sea-quarks
5822 CALL DT_SPLFLA(NN,1)
5824 * sample x-values of partons at chain ends
5826 CALL DT_XKSAMP(NN,ECM)
5829 CALL DT_SPLFLA(NN,2)
5834 *$ CREATE DT_SPLFLA.FOR
5837 *===splfla=============================================================*
5839 SUBROUTINE DT_SPLFLA(NN,MODE)
5841 ************************************************************************
5842 * SamPLing of FLAvors of partons at chain ends. *
5843 * This subroutine replaces FLKSAA/FLKSAM. *
5844 * NN number of nucleon-nucleon interactions *
5845 * MODE = 1 sea-flavors *
5846 * = 2 valence-flavors *
5847 * Based on the original version written by J. Ranft/H.-J. Moehring. *
5848 * This version dated 16.01.95 is written by S. Roesler *
5849 ************************************************************************
5851 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5853 PARAMETER ( LINP = 10 ,
5857 PARAMETER ( MAXNCL = 260,
5859 & MAXSQU = 20*MAXVQU,
5860 & MAXINT = MAXVQU+MAXSQU)
5861 * flavors of partons (DTUNUC 1.x)
5862 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5863 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5864 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5865 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5866 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5867 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5868 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5869 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5870 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5871 & IXPV,IXPS,IXTV,IXTS,
5872 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5873 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5874 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5875 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5876 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5877 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5878 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5879 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5880 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5881 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5882 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5883 * particle properties (BAMJET index convention)
5885 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5886 & IICH(210),IIBAR(210),K1(210),K2(210)
5887 * various options for treatment of partons (DTUNUC 1.x)
5888 * (chain recombination, Cronin,..)
5889 LOGICAL LCO2CR,LINTPT
5890 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5896 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5900 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5903 ELSEIF (MODE.EQ.2) THEN
5906 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5909 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5916 *$ CREATE DT_GETPTN.FOR
5919 *===getptn=============================================================*
5921 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5923 ************************************************************************
5924 * This subroutine collects partons at chain ends from temporary *
5925 * commons and puts them into DTEVT1. *
5926 * This version dated 15.01.95 is written by S. Roesler *
5927 ************************************************************************
5929 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5931 PARAMETER ( LINP = 10 ,
5934 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5938 PARAMETER ( MAXNCL = 260,
5940 & MAXSQU = 20*MAXVQU,
5941 & MAXINT = MAXVQU+MAXSQU)
5943 PARAMETER (NMXHKK=200000)
5944 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5945 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5946 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5947 * extended event history
5948 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5949 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5951 * flags for input different options
5952 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5953 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5954 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5955 * auxiliary common for chain system storage (DTUNUC 1.x)
5956 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5958 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5959 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5961 * flags for diffractive interactions (DTUNUC 1.x)
5962 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5963 * x-values of partons (DTUNUC 1.x)
5964 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5965 & XTVQ(MAXVQU),XTVD(MAXVQU),
5966 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
5967 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
5968 * flavors of partons (DTUNUC 1.x)
5969 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5970 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5971 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5972 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5973 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5974 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5975 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5976 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5977 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5978 & IXPV,IXPS,IXTV,IXTS,
5979 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5980 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5981 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5982 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5983 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5984 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5985 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5986 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5987 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5988 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5989 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5991 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
5993 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6001 IF (ISKPCH(1,I).EQ.99) GOTO 10
6002 ICCHAI(1,1) = ICCHAI(1,1)+2
6005 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6006 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6008 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6009 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6010 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6011 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6013 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6014 & +(PP1(3)+PT1(3))**2)
6016 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6017 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6018 & +(PP2(3)+PT2(3))**2)
6020 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6021 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6024 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6025 C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6026 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6029 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6031 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6032 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6033 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6034 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6035 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6037 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6039 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6041 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6048 IF (ISKPCH(2,I).EQ.99) GOTO 20
6049 ICCHAI(1,2) = ICCHAI(1,2)+2
6052 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6053 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6055 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6056 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6057 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6058 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6060 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6061 & +(PP1(3)+PT1(3))**2)
6063 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6064 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6065 & +(PP2(3)+PT2(3))**2)
6067 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6068 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6071 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6072 C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6073 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6076 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6078 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6079 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6080 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6081 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6082 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6084 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6086 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6088 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6095 IF (ISKPCH(3,I).EQ.99) GOTO 30
6096 ICCHAI(1,3) = ICCHAI(1,3)+2
6099 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6100 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6102 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6103 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6104 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6105 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6107 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6108 & +(PP1(3)+PT1(3))**2)
6110 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6111 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6112 & +(PP2(3)+PT2(3))**2)
6114 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6115 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6118 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6119 C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6120 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6123 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6125 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6126 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6127 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6128 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6129 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6131 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6133 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6135 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6140 * disea-valence chains
6142 IF (ISKPCH(5,I).EQ.99) GOTO 50
6143 ICCHAI(1,5) = ICCHAI(1,5)+2
6146 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6147 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6149 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6150 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6151 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6152 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6154 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6155 & +(PP1(3)+PT1(3))**2)
6157 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6158 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6159 & +(PP2(3)+PT2(3))**2)
6161 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6162 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6165 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6166 C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6167 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6170 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6172 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6173 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6174 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6175 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6176 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6178 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6180 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6182 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6187 * valence-sea chains
6189 IF (ISKPCH(6,I).EQ.99) GOTO 60
6190 ICCHAI(1,6) = ICCHAI(1,6)+2
6193 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6194 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6196 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6197 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6198 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6199 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6201 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6202 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6203 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6204 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6205 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6207 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6209 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6211 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6213 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6215 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6216 & +(PP1(3)+PT1(3))**2)
6218 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6219 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6220 & +(PP2(3)+PT2(3))**2)
6222 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6224 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6226 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6228 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6230 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6232 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6233 & +(PP1(3)+PT2(3))**2)
6235 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6236 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6237 & +(PP2(3)+PT1(3))**2)
6239 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6241 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6244 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6245 C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6246 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6249 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6254 * sea-valence chains
6256 IF (ISKPCH(4,I).EQ.99) GOTO 40
6257 ICCHAI(1,4) = ICCHAI(1,4)+2
6260 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6261 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6263 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6264 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6265 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6266 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6268 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6269 & +(PP1(3)+PT1(3))**2)
6271 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6272 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6273 & +(PP2(3)+PT2(3))**2)
6275 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6276 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6279 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6280 C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6281 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6284 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6286 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6287 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6288 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6289 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6290 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6292 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6294 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6296 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6301 * valence-disea chains
6303 IF (ISKPCH(7,I).EQ.99) GOTO 70
6304 ICCHAI(1,7) = ICCHAI(1,7)+2
6307 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6308 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6310 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6311 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6312 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6313 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6315 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6316 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6317 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6318 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6319 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6321 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6323 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6325 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6327 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6329 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6330 & +(PP1(3)+PT1(3))**2)
6332 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6333 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6334 & +(PP2(3)+PT2(3))**2)
6336 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6338 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6340 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6342 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6344 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6346 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6347 & +(PP1(3)+PT2(3))**2)
6349 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6350 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6351 & +(PP2(3)+PT1(3))**2)
6353 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6355 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6358 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6359 C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6360 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6363 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6368 * valence-valence chains
6370 IF (ISKPCH(8,I).EQ.99) GOTO 80
6371 ICCHAI(1,8) = ICCHAI(1,8)+2
6374 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6375 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6377 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6378 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6379 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6380 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6382 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6383 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6384 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6385 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6387 * check for diffractive event
6389 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6390 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6392 PP(K) = PP1(K)+PP2(K)
6393 PT(K) = PT1(K)+PT2(K)
6396 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6397 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6398 C IF (IREJ1.NE.0) GOTO 9999
6399 IF (IREJ1.NE.0) THEN
6407 IF (IDIFF.EQ.0) THEN
6408 * valence-valence chain system
6409 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6412 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6413 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6414 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6415 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6416 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6417 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6418 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6419 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6420 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6421 & +(PP1(3)+PT1(3))**2)
6423 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6424 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6425 & +(PP2(3)+PT2(3))**2)
6427 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6430 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6431 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6432 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6433 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6434 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6435 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6436 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6437 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6438 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6439 & +(PP1(3)+PT2(3))**2)
6441 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6442 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6443 & +(PP2(3)+PT1(3))**2)
6445 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6447 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6450 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6451 C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6452 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6455 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6460 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6462 * energy-momentum & flavor conservation check
6463 IF (ABS(IDIFF).NE.1) THEN
6464 IF (IDIFF.NE.0) THEN
6465 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6468 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6484 *$ CREATE DT_CHKCSY.FOR
6487 *===chkcsy=============================================================*
6489 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6491 ************************************************************************
6492 * CHeCk Chain SYstem for consistency of partons at chain ends. *
6493 * ID1,ID2 PDG-numbers of partons at chain ends *
6494 * LCHK = .true. consistent chain *
6495 * = .false. inconsistent chain *
6496 * This version dated 18.01.95 is written by S. Roesler *
6497 ************************************************************************
6499 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6501 PARAMETER ( LINP = 10 ,
6510 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6511 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6512 * q-qq, aq-aqaq chain
6513 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6514 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6515 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6517 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6518 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6524 *$ CREATE DT_EVENTA.FOR
6527 *===eventa=============================================================*
6529 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6531 ************************************************************************
6532 * Treatment of nucleon-nucleon interactions in a two-chain *
6534 * (input) ID BAMJET-index of projectile hadron (in case of *
6536 * IP/IT mass number of projectile/target nucleus *
6537 * NCSY number of two chain systems *
6538 * IREJ rejection flag *
6539 * This version dated 15.01.95 is written by S. Roesler *
6540 ************************************************************************
6542 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6544 PARAMETER ( LINP = 10 ,
6547 PARAMETER (TINY10=1.0D-10)
6550 PARAMETER (NMXHKK=200000)
6551 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6552 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6553 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6554 * extended event history
6555 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6556 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6559 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6560 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6561 & IREXCI(3),IRDIFF(2),IRINC
6562 * flags for diffractive interactions (DTUNUC 1.x)
6563 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6564 * particle properties (BAMJET index convention)
6566 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6567 & IICH(210),IIBAR(210),K1(210),K2(210)
6568 * flags for input different options
6569 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6570 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6571 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6572 * various options for treatment of partons (DTUNUC 1.x)
6573 * (chain recombination, Cronin,..)
6574 LOGICAL LCO2CR,LINTPT
6575 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6578 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6583 * skip following treatment for low-mass diffraction
6584 IF (ABS(IFLAGD).EQ.1) THEN
6585 NPOINT(3) = NPOINT(2)
6589 * multiple scattering of chain ends
6590 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6591 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6594 * get a two-chain system from DTEVT1
6602 PT1(K) = PHKK(K,NC+1)
6603 PP2(K) = PHKK(K,NC+2)
6604 PT2(K) = PHKK(K,NC+3)
6610 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6611 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6612 IF (IREJ1.GT.0) THEN
6614 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6620 * meson/antibaryon projectile:
6621 * sample single-chain valence-valence systems (Reggeon contrib.)
6622 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6623 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6626 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6627 * check DTEVT1 for remaining resonance mass corrections
6628 CALL DT_EVTRES(IREJ1)
6629 IF (IREJ1.GT.0) THEN
6630 IRRES(1) = IRRES(1)+1
6631 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6636 * assign p_t to two-"chain" systems consisting of two resonances only
6637 * since only entries for chains will be affected, this is obsolete
6638 * in case of JETSET-fragmetation
6641 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6642 IF (LCO2CR) CALL DT_COM2CR
6646 * fragmentation of the complete event
6647 **uncomment for internal phojet-fragmentation
6648 C CALL DT_EVTFRA(IREJ1)
6649 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6650 IF (IREJ1.GT.0) THEN
6652 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6656 * decay of possible resonances (should be obsolete)
6667 *$ CREATE DT_GETCSY.FOR
6670 *===getcsy=============================================================*
6672 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6673 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6675 ************************************************************************
6676 * This version dated 15.01.95 is written by S. Roesler *
6677 ************************************************************************
6679 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6681 PARAMETER ( LINP = 10 ,
6684 PARAMETER (TINY10=1.0D-10)
6687 PARAMETER (NMXHKK=200000)
6688 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6689 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6690 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6691 * extended event history
6692 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6693 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6696 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6697 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6698 & IREXCI(3),IRDIFF(2),IRINC
6699 * flags for input different options
6700 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6701 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6702 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6703 * flags for diffractive interactions (DTUNUC 1.x)
6704 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6706 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6707 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6711 * get quark content of partons
6718 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6719 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6720 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6721 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6722 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6723 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6724 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6725 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6727 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6729 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6730 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6732 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6733 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6735 * store initial configuration for energy-momentum cons. check
6736 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6738 * sample intrinsic p_t at chain-ends
6739 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6740 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6741 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6742 IF (IREJ1.NE.0) THEN
6743 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6748 C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6749 C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6750 C* check second chain for resonance
6751 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6752 C & AMCH2,AMCH2N,IDCH2,IREJ1)
6753 C IF (IREJ1.NE.0) GOTO 9999
6754 C IF (IDR2.NE.0) THEN
6755 C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6756 C & AMCH2,AMCH2N,AMCH1,IREJ1)
6757 C IF (IREJ1.NE.0) GOTO 9999
6759 C* check first chain for resonance
6760 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6761 C & AMCH1,AMCH1N,IDCH1,IREJ1)
6762 C IF (IREJ1.NE.0) GOTO 9999
6763 C IF (IDR1.NE.0) IDR1 = 100*IDR1
6765 C* check first chain for resonance
6766 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6767 C & AMCH1,AMCH1N,IDCH1,IREJ1)
6768 C IF (IREJ1.NE.0) GOTO 9999
6769 C IF (IDR1.NE.0) THEN
6770 C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6771 C & AMCH1,AMCH1N,AMCH2,IREJ1)
6772 C IF (IREJ1.NE.0) GOTO 9999
6774 C* check second chain for resonance
6775 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6776 C & AMCH2,AMCH2N,IDCH2,IREJ1)
6777 C IF (IREJ1.NE.0) GOTO 9999
6778 C IF (IDR2.NE.0) IDR2 = 100*IDR2
6782 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6783 * check chains for resonances
6784 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6785 & AMCH1,AMCH1N,IDCH1,IREJ1)
6786 IF (IREJ1.NE.0) GOTO 9999
6787 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6788 & AMCH2,AMCH2N,IDCH2,IREJ1)
6789 IF (IREJ1.NE.0) GOTO 9999
6790 * change kinematics corresponding to resonance-masses
6791 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6792 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6793 & AMCH1,AMCH1N,AMCH2,IREJ1)
6794 IF (IREJ1.GT.0) GOTO 9999
6795 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6796 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6797 & AMCH2,AMCH2N,IDCH2,IREJ1)
6798 IF (IREJ1.NE.0) GOTO 9999
6799 IF (IDR2.NE.0) IDR2 = 100*IDR2
6800 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6801 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6802 & AMCH2,AMCH2N,AMCH1,IREJ1)
6803 IF (IREJ1.GT.0) GOTO 9999
6804 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6805 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6806 & AMCH1,AMCH1N,IDCH1,IREJ1)
6807 IF (IREJ1.NE.0) GOTO 9999
6808 IF (IDR1.NE.0) IDR1 = 100*IDR1
6809 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6810 AMDIF1 = ABS(AMCH1-AMCH1N)
6811 AMDIF2 = ABS(AMCH2-AMCH2N)
6812 IF (AMDIF2.LT.AMDIF1) 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),
6818 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6819 IF (IREJ1.NE.0) GOTO 9999
6820 IF (IDR1.NE.0) IDR1 = 100*IDR1
6822 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6823 & AMCH1,AMCH1N,AMCH2,IREJ1)
6824 IF (IREJ1.GT.0) GOTO 9999
6825 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6826 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6827 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6828 IF (IREJ1.NE.0) GOTO 9999
6829 IF (IDR2.NE.0) IDR2 = 100*IDR2
6834 * store final configuration for energy-momentum cons. check
6836 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6837 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6838 IF (IREJ1.NE.0) GOTO 9999
6841 * put partons and chains into DTEVT1
6843 PCH1(I) = PP1(I)+PT1(I)
6844 PCH2(I) = PP2(I)+PT2(I)
6846 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6847 & PP1(3),PP1(4),0,0,0)
6848 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6849 & PT1(3),PT1(4),0,0,0)
6850 KCH = 100+IDCH(MOP1)*10+1
6851 CALL DT_EVTPUT(KCH,88888,-2,-1,
6852 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6853 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6854 & PP2(3),PP2(4),0,0,0)
6855 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6856 & PT2(3),PT2(4),0,0,0)
6858 CALL DT_EVTPUT(KCH,88888,-2,-1,
6859 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6864 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6865 * "cancel" sea-sea chains
6866 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6867 IF (IREJ1.NE.0) GOTO 9998
6868 **sr 16.5. flag for EVENTB
6877 *$ CREATE DT_CHKINE.FOR
6880 *===chkine=============================================================*
6882 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6883 & AMCH1,AMCH1N,AMCH2,IREJ)
6885 ************************************************************************
6886 * This subroutine replaces CORMOM. *
6887 * This version dated 05.01.95 is written by S. Roesler *
6888 ************************************************************************
6890 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6892 PARAMETER ( LINP = 10 ,
6895 PARAMETER (TINY10=1.0D-10)
6897 * flags for input different options
6898 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6899 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6900 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6902 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6903 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6904 & IREXCI(3),IRDIFF(2),IRINC
6906 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6907 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6912 SCALE = AMCH1N/MAX(AMCH1,TINY10)
6918 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6919 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6920 PP1(I) = SCALE*PP1(I)
6921 PT1(I) = SCALE*PT1(I)
6923 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6924 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6927 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6928 & (PP2(3)+PT2(3))**2 )
6929 AMCH22 = (ECH-PCH)*(ECH+PCH)
6930 IF (AMCH22.LT.0.0D0) THEN
6932 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6937 AMCH2 = SQRT(AMCH22)
6939 * put partons again on mass shell
6943 IF (JMSHL.EQ.1) THEN
6947 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6948 IF (IREJ1.NE.0) THEN
6949 IF (JMSHL.EQ.0) GOTO 9998
6961 IF (JMSHL.EQ.1) THEN
6965 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6966 IF (IREJ1.NE.0) THEN
6967 IF (JMSHL.EQ.0) GOTO 9998
6983 9997 IRCHKI(1) = IRCHKI(1)+1
6989 9998 IRCHKI(2) = IRCHKI(2)+1
6992 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
6997 *$ CREATE DT_CH2RES.FOR
7000 *===ch2res=============================================================*
7002 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7003 & AM,AMN,IMODE,IREJ)
7005 ************************************************************************
7006 * Check chains for resonance production. *
7007 * This subroutine replaces COMCMA/COBCMA/COMCM2 *
7009 * IF1,2,3,4 input flavors (q,aq in any order) *
7011 * MODE = 1 check q-aq chain for meson-resonance *
7012 * = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7013 * = 3 check qq-aqaq chain for lower mass cut *
7015 * IDR = 0 no resonances found *
7016 * = -1 pseudoscalar meson/octet baryon *
7017 * = 1 vector-meson/decuplet baryon *
7018 * IDXR BAMJET-index of corresponding resonance *
7019 * AMN mass of corresponding resonance *
7021 * IREJ rejection flag *
7022 * This version dated 06.01.95 is written by S. Roesler *
7023 ************************************************************************
7025 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7027 PARAMETER ( LINP = 10 ,
7031 * particle properties (BAMJET index convention)
7033 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7034 & IICH(210),IIBAR(210),K1(210),K2(210)
7035 * quark-content to particle index conversion (DTUNUC 1.x)
7036 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7037 & IA08(6,21),IA10(6,21)
7039 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7040 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7041 & IREXCI(3),IRDIFF(2),IRINC
7042 * flags for input different options
7043 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7044 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7045 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7047 DIMENSION IF(4),JF(4)
7050 C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7051 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7053 C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7057 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7058 WRITE(LOUT,1000) MODE
7059 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7060 & 1X,' program stopped')
7069 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7070 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7078 IF (IF(I).NE.0) THEN
7083 IF (NF.LE.MODE) THEN
7084 WRITE(LOUT,1001) MODE,IF
7085 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7086 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7092 * check for meson resonance
7096 IF (JF(2).GT.0) THEN
7100 IFPS = IMPS(IFAQ,IFQ)
7101 IFV = IMVE(IFAQ,IFQ)
7105 IF (AMX.LT.AMV) THEN
7106 IF (AMX.LT.AMPS) THEN
7107 IF (IMODE.GT.0) THEN
7108 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7110 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7114 * replace chain by pseudoscalar meson
7118 ELSEIF (AMX.LT.AMHI) THEN
7119 * replace chain by vector-meson
7126 * check for baryon resonance
7128 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7132 IF (AMX.LT.AM10) THEN
7133 IF (AMX.LT.AM8) THEN
7134 IF (IMODE.GT.0) THEN
7135 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7137 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7141 * replace chain by oktet baryon
7145 ELSEIF (AMX.LT.AMHI) THEN
7152 * check qq-aqaq for lower mass cut
7154 * empirical definition of AMHI to allow for (b-antib)-pair prod.
7156 IF (AMX.LT.AMHI) GOTO 9999
7160 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7161 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7163 IRRES(2) = IRRES(2)+1
7167 *$ CREATE DT_RJSEAC.FOR
7170 *===rjseac=============================================================*
7172 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7174 ************************************************************************
7175 * ReJection of SEA-sea Chains. *
7176 * MOP1/2 entries of projectile sea-partons in DTEVT1 *
7177 * MOT1/2 entries of projectile sea-partons in DTEVT1 *
7178 * This version dated 16.01.95 is written by S. Roesler *
7179 ************************************************************************
7181 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7183 PARAMETER ( LINP = 10 ,
7186 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7189 PARAMETER (NMXHKK=200000)
7190 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7191 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7192 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7193 * extended event history
7194 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7195 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7198 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7199 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7202 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7206 * projectile sea q-aq-pair
7207 * indices of sea-pair
7210 * index of mother-nucleon
7211 IDXNUC(1) = JMOHKK(1,MOP1)
7212 * status of valence quarks to be corrected
7215 * target sea q-aq-pair
7216 * indices of sea-pair
7219 * index of mother-nucleon
7220 IDXNUC(2) = JMOHKK(1,MOT1)
7221 * status of valence quarks to be corrected
7226 DO 2 I=NPOINT(2),NHKK
7227 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7228 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7229 * valence parton found
7230 * inrease 4-momentum by sea 4-momentum
7232 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7233 & PHKK(K,IDXSEA(N,2))
7235 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7236 & PHKK(2,I)**2-PHKK(3,I)**2))
7239 ISTHKK(IDXSEA(N,J)) = 100
7240 IDHKK(IDXSEA(N,J)) = 0
7241 JMOHKK(1,IDXSEA(N,J)) = 0
7242 JMOHKK(2,IDXSEA(N,J)) = 0
7243 JDAHKK(1,IDXSEA(N,J)) = 0
7244 JDAHKK(2,IDXSEA(N,J)) = 0
7246 PHKK(K,IDXSEA(N,J)) = ZERO
7247 VHKK(K,IDXSEA(N,J)) = ZERO
7248 WHKK(K,IDXSEA(N,J)) = ZERO
7250 PHKK(5,IDXSEA(N,J)) = ZERO
7255 IF (IDONE.NE.1) THEN
7256 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7257 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7258 & '-record!',/,1X,' sea-quark pairs ',
7259 & 2I5,4X,2I5,' could not be canceled!')
7271 *$ CREATE DT_VV2SCH.FOR
7274 *===vv2sch=============================================================*
7276 SUBROUTINE DT_VV2SCH
7278 ************************************************************************
7279 * Change Valence-Valence chain systems to Single CHain systems for *
7280 * hadron-nucleus collisions with meson or antibaryon projectile. *
7281 * (Reggeon contribution) *
7282 * The single chain system is approximately treated as one chain and a *
7284 * This version dated 18.01.95 is written by S. Roesler *
7285 ************************************************************************
7287 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7289 PARAMETER ( LINP = 10 ,
7292 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7297 PARAMETER (NMXHKK=200000)
7298 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7299 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7300 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7301 * extended event history
7302 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7303 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7305 * flags for input different options
7306 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7307 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7308 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7310 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7311 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7314 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7317 DATA LSTART /.TRUE./
7322 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7323 & 'valence chains treated')
7329 * get index of first chain
7330 DO 1 I=NPOINT(3),NHKK
7331 IF (IDHKK(I).EQ.88888) THEN
7338 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7339 & .AND.(NC.LT.NSTOP)) THEN
7340 * get valence-valence chains
7341 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7342 * get "mother"-hadron indices
7343 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7344 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7345 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7346 KTARG = IDT_ICIHAD(IDHKK(MO2))
7347 * Lab momentum of projectile hadron
7348 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7349 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7352 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7353 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7355 * single chain requested
7356 * get flavors of chain-end partons
7357 MO(1) = JMOHKK(1,NC)
7358 MO(2) = JMOHKK(2,NC)
7359 MO(3) = JMOHKK(1,NC+3)
7360 MO(4) = JMOHKK(2,NC+3)
7362 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7364 IF (ABS(IDHKK(MO(I))).GE.1000)
7365 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7367 * which one is the q-aq chain?
7368 * N1,N1+1 - DTEVT1-entries for q-aq system
7369 * N2,N2+1 - DTEVT1-entries for the other chain
7370 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7375 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7385 PT1(K) = PHKK(K,N1+1)
7387 PT2(K) = PHKK(K,N2+1)
7389 AMCH1 = PHKK(5,N1+2)
7390 AMCH2 = PHKK(5,N2+2)
7391 * get meson-identity corresponding to flavors of q-aq chain
7394 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7395 & ZERO,AMCH1N,1,IDUM)
7397 * change kinematics of chains
7398 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7399 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7400 & AMCH1,AMCH1N,AMCH2,IREJ1)
7401 IF (IREJ1.NE.0) GOTO 10
7402 * check second chain for resonance
7404 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7405 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7406 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7407 IF (IREJ1.NE.0) GOTO 10
7408 IF (IDR2.NE.0) IDR2 = 100*IDR2
7409 * add partons and chains to DTEVT1
7411 PCH1(K) = PP1(K)+PT1(K)
7412 PCH2(K) = PP2(K)+PT2(K)
7414 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7415 & PP1(3),PP1(4),0,0,0)
7416 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7417 & PT1(2),PT1(3),PT1(4),0,0,0)
7418 KCH = ISTHKK(N1+2)+100
7419 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7420 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7422 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7423 & PP2(3),PP2(4),0,0,0)
7424 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7425 & PT2(2),PT2(3),PT2(4),0,0,0)
7426 KCH = ISTHKK(N2+2)+100
7427 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7428 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7444 *$ CREATE DT_PHNSCH.FOR
7447 *=== phnsch ===========================================================*
7449 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7451 *----------------------------------------------------------------------*
7453 * Probability for Hadron Nucleon Single CHain interactions: *
7455 * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7458 * Last change on 04-jan-94 by Alfredo Ferrari *
7460 * modified by J.R.for use in DTUNUC 6.1.94 *
7462 * Input variables: *
7463 * Kp = hadron projectile index (Part numbering *
7465 * Ktarg = target nucleon index (1=proton, 8=neutron) *
7466 * Plab = projectile laboratory momentum (GeV/c) *
7467 * Output variable: *
7468 * Phnsch = probability per single chain (particle *
7469 * exchange) interactions *
7471 *----------------------------------------------------------------------*
7473 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7476 PARAMETER ( LUNOUT = 6 )
7477 PARAMETER ( LUNERR = 6 )
7478 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7479 PARAMETER ( ZERZER = 0.D+00 )
7480 PARAMETER ( ONEONE = 1.D+00 )
7481 PARAMETER ( TWOTWO = 2.D+00 )
7482 PARAMETER ( FIVFIV = 5.D+00 )
7483 PARAMETER ( HLFHLF = 0.5D+00 )
7485 PARAMETER ( NALLWP = 39 )
7486 PARAMETER ( IDMAXP = 210 )
7488 DIMENSION ICHRGE(39),AM(39)
7490 * particle properties (BAMJET index convention)
7492 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7493 & IICH(210),IIBAR(210),K1(210),K2(210)
7495 DIMENSION KPTOIP(210)
7496 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7497 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7498 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7499 & IQTCHR(-6:6),MQUARK(3,39)
7501 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7502 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7503 CPH SAVE SGTCOE, IHLP
7504 CPH SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7505 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7506 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7507 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7509 * Conversion from part to paprop numbering
7510 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7511 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7512 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7514 * 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7515 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7516 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7517 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7519 * 1st reaction: gamma p total
7520 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7521 * 2nd reaction: gamma d total
7522 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7523 * 3rd reaction: pi+ p total
7524 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7525 * 4th reaction: pi- p total
7526 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7527 * 5th reaction: pi+/- d total
7528 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7529 * 6th reaction: K+ p total
7530 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7531 * 7th reaction: K+ n total
7532 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7533 * 8th reaction: K+ d total
7534 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7535 * 9th reaction: K- p total
7536 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7537 * 10th reaction: K- n total
7538 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7539 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7541 * 11th reaction: K- d total
7542 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7543 * 12th reaction: p p total
7544 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7545 * 13th reaction: p n total
7546 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7547 * 14th reaction: p d total
7548 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
7549 * 15th reaction: pbar p total
7550 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
7551 * 16th reaction: pbar n total
7552 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
7553 * 17th reaction: pbar d total
7554 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
7555 * 18th reaction: Lamda p total
7556 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
7557 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7559 * 19th reaction: pi+ p elastic
7560 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
7561 * 20th reaction: pi- p elastic
7562 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
7563 * 21st reaction: K+ p elastic
7564 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
7565 * 22nd reaction: K- p elastic
7566 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
7567 * 23rd reaction: p p elastic
7568 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
7569 * 24th reaction: p d elastic
7570 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
7571 * 25th reaction: pbar p elastic
7572 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
7573 * 26th reaction: pbar p elastic bis
7574 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
7575 * 27th reaction: pbar n elastic
7576 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
7577 * 28th reaction: Lamda p elastic
7578 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
7579 * 29th reaction: K- p ela bis
7580 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
7581 * 30th reaction: pi- p cx
7582 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
7583 * 31st reaction: K- p cx
7584 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
7585 * 32nd reaction: K+ n cx
7586 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
7587 * 33rd reaction: pbar p cx
7588 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
7590 * +-------------------------------------------------------------------*
7591 ICHRGE(KTARG)=IICH(KTARG)
7592 AM (KTARG)=AAM (KTARG)
7593 * | Check for pi0 (d-dbar)
7594 IF ( KP .NE. 26 ) THEN
7600 * +-------------------------------------------------------------------*
7607 * +-------------------------------------------------------------------*
7608 * +-------------------------------------------------------------------*
7609 * | No such interactions for baryon-baryon
7610 IF ( IIBAR (KP) .GT. 0 ) THEN
7614 * +-------------------------------------------------------------------*
7615 * | No "annihilation" diagram possible for K+ p/n
7616 ELSE IF ( IP .EQ. 15 ) THEN
7620 * +-------------------------------------------------------------------*
7621 * | No "annihilation" diagram possible for K0 p/n
7622 ELSE IF ( IP .EQ. 24 ) THEN
7626 * +-------------------------------------------------------------------*
7627 * | No "annihilation" diagram possible for Omebar p/n
7628 ELSE IF ( IP .GE. 38 ) THEN
7633 * +-------------------------------------------------------------------*
7634 * +-------------------------------------------------------------------*
7635 * | If the momentum is larger than 50 GeV/c, compute the single
7636 * | chain probability at 50 GeV/c and extrapolate to the present
7637 * | momentum according to 1/sqrt(s)
7638 * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7639 * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7640 * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7641 * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7643 * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7644 IF ( PLAB .GT. 50.D+00 ) THEN
7647 AMTSQ = AM (KTARG)**2
7648 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7649 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7650 EPROJ = SQRT ( PLA**2 + AMPSQ )
7651 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7652 UMORAT = SQRT ( UMOSQ / UMO50 )
7654 * +-------------------------------------------------------------------*
7656 ELSE IF ( PLAB .LT. 3.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 * +-------------------------------------------------------------------*
7673 * +-------------------------------------------------------------------*
7675 * +-------------------------------------------------------------------*
7677 IF ( IHLP (IP) .EQ. 2 ) THEN
7683 * | Compute the pi+ p total cross section:
7684 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7686 ACOF = SGTCOE (1,19)
7687 BCOF = SGTCOE (2,19)
7688 ENNE = SGTCOE (3,19)
7689 CCOF = SGTCOE (4,19)
7690 DCOF = SGTCOE (5,19)
7691 * | Compute the pi+ p elastic cross section:
7692 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7694 * | Compute the pi+ p inelastic cross section:
7695 SPPPIN = SPPPTT - SPPPEL
7701 * | Compute the pi- p total cross section:
7702 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7704 ACOF = SGTCOE (1,20)
7705 BCOF = SGTCOE (2,20)
7706 ENNE = SGTCOE (3,20)
7707 CCOF = SGTCOE (4,20)
7708 DCOF = SGTCOE (5,20)
7709 * | Compute the pi- p elastic cross section:
7710 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7712 * | Compute the pi- p inelastic cross section:
7713 SPMPIN = SPMPTT - SPMPEL
7714 SIGDIA = SPMPIN - SPPPIN
7715 * | +----------------------------------------------------------------*
7716 * | | Charged pions: besides isospin consideration it is supposed
7717 * | | that (pi+ n)el is almost equal to (pi- p)el
7718 * | | and (pi+ p)el " " " " (pi- n)el
7719 * | | and all are almost equal among each others
7720 * | | (reasonable above 5 GeV/c)
7721 IF ( ICHRGE (IP) .NE. 0 ) THEN
7723 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7724 ACOF = SGTCOE (1,JREAC)
7725 BCOF = SGTCOE (2,JREAC)
7726 ENNE = SGTCOE (3,JREAC)
7727 CCOF = SGTCOE (4,JREAC)
7728 DCOF = SGTCOE (5,JREAC)
7729 * | | Compute the total cross section:
7730 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7732 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7733 ACOF = SGTCOE (1,JREAC)
7734 BCOF = SGTCOE (2,JREAC)
7735 ENNE = SGTCOE (3,JREAC)
7736 CCOF = SGTCOE (4,JREAC)
7737 DCOF = SGTCOE (5,JREAC)
7738 * | | Compute the elastic cross section:
7739 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7741 * | | Compute the inelastic cross section:
7742 SHNCIN = SHNCTT - SHNCEL
7743 * | | Number of diagrams:
7744 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7745 * | | Now compute the chain end (anti)quark-(anti)diquark
7746 IQFSC1 = 1 + IP - 13
7749 IQBSC2 = 1 + IP - 13
7751 * | +----------------------------------------------------------------*
7752 * | | pi0: besides isospin consideration it is supposed that the
7753 * | | elastic cross section is not very different from
7754 * | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
7757 K2HLP = ( KP - 23 ) / 3
7758 * | | Number of diagrams:
7759 * | | For u ubar (k2hlp=0):
7760 * NDIAGR = 2 - KHELP
7761 * | | For d dbar (k2hlp=1):
7762 * NDIAGR = 2 + KHELP - K2HLP
7763 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7764 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7765 * | | Now compute the chain end (anti)quark-(anti)diquark
7772 * | +----------------------------------------------------------------*
7774 * +-------------------------------------------------------------------*
7776 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7782 * | Compute the K+ p total cross section:
7783 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7785 ACOF = SGTCOE (1,21)
7786 BCOF = SGTCOE (2,21)
7787 ENNE = SGTCOE (3,21)
7788 CCOF = SGTCOE (4,21)
7789 DCOF = SGTCOE (5,21)
7790 * | Compute the K+ p elastic cross section:
7791 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7793 * | Compute the K+ p inelastic cross section:
7794 SKPPIN = SKPPTT - SKPPEL
7800 * | Compute the K- p total cross section:
7801 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7803 ACOF = SGTCOE (1,22)
7804 BCOF = SGTCOE (2,22)
7805 ENNE = SGTCOE (3,22)
7806 CCOF = SGTCOE (4,22)
7807 DCOF = SGTCOE (5,22)
7808 * | Compute the K- p elastic cross section:
7809 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7811 * | Compute the K- p inelastic cross section:
7812 SKMPIN = SKMPTT - SKMPEL
7813 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7814 * | +----------------------------------------------------------------*
7815 * | | Charged Kaons: actually only K-
7816 IF ( ICHRGE (IP) .NE. 0 ) THEN
7818 * | | +-------------------------------------------------------------*
7819 * | | | Proton target:
7820 IF ( KHELP .EQ. 0 ) THEN
7822 * | | | Number of diagrams:
7825 * | | +-------------------------------------------------------------*
7826 * | | | Neutron target: besides isospin consideration it is supposed
7827 * | | | that (K- n)el is almost equal to (K- p)el
7828 * | | | (reasonable above 5 GeV/c)
7830 ACOF = SGTCOE (1,10)
7831 BCOF = SGTCOE (2,10)
7832 ENNE = SGTCOE (3,10)
7833 CCOF = SGTCOE (4,10)
7834 DCOF = SGTCOE (5,10)
7835 * | | | Compute the total cross section:
7836 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7838 * | | | Compute the elastic cross section:
7840 * | | | Compute the inelastic cross section:
7841 SHNCIN = SHNCTT - SHNCEL
7842 * | | | Number of diagrams:
7846 * | | +-------------------------------------------------------------*
7847 * | | Now compute the chain end (anti)quark-(anti)diquark
7853 * | +----------------------------------------------------------------*
7854 * | | K0's: (actually only K0bar)
7857 * | | +-------------------------------------------------------------*
7858 * | | | Proton target: (K0bar p)in supposed to be given by
7859 * | | | (K- p)in - Sig_diagr
7860 IF ( KHELP .EQ. 0 ) THEN
7861 SHNCIN = SKMPIN - SIGDIA
7862 * | | | Number of diagrams:
7865 * | | +-------------------------------------------------------------*
7866 * | | | Neutron target: (K0bar n)in supposed to be given by
7867 * | | | (K- n)in + Sig_diagr
7868 * | | | besides isospin consideration it is supposed
7869 * | | | that (K- n)el is almost equal to (K- p)el
7870 * | | | (reasonable above 5 GeV/c)
7872 ACOF = SGTCOE (1,10)
7873 BCOF = SGTCOE (2,10)
7874 ENNE = SGTCOE (3,10)
7875 CCOF = SGTCOE (4,10)
7876 DCOF = SGTCOE (5,10)
7877 * | | | Compute the total cross section:
7878 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7880 * | | | Compute the elastic cross section:
7882 * | | | Compute the inelastic cross section:
7883 SHNCIN = SHNCTT - SHNCEL + SIGDIA
7884 * | | | Number of diagrams:
7888 * | | +-------------------------------------------------------------*
7889 * | | Now compute the chain end (anti)quark-(anti)diquark
7896 * | +----------------------------------------------------------------*
7898 * +-------------------------------------------------------------------*
7900 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7901 * | For momenta between 3 and 5 GeV/c the use of tabulated data
7902 * | should be implemented!
7903 ACOF = SGTCOE (1,15)
7904 BCOF = SGTCOE (2,15)
7905 ENNE = SGTCOE (3,15)
7906 CCOF = SGTCOE (4,15)
7907 DCOF = SGTCOE (5,15)
7908 * | Compute the pbar p total cross section:
7909 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7911 IF ( PLA .LT. FIVFIV ) THEN
7916 ACOF = SGTCOE (1,JREAC)
7917 BCOF = SGTCOE (2,JREAC)
7918 ENNE = SGTCOE (3,JREAC)
7919 CCOF = SGTCOE (4,JREAC)
7920 DCOF = SGTCOE (5,JREAC)
7921 * | Compute the pbar p elastic cross section:
7922 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7924 * | Compute the pbar p inelastic cross section:
7925 SAPPIN = SAPPTT - SAPPEL
7926 ACOF = SGTCOE (1,12)
7927 BCOF = SGTCOE (2,12)
7928 ENNE = SGTCOE (3,12)
7929 CCOF = SGTCOE (4,12)
7930 DCOF = SGTCOE (5,12)
7931 * | Compute the p p total cross section:
7932 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7934 ACOF = SGTCOE (1,23)
7935 BCOF = SGTCOE (2,23)
7936 ENNE = SGTCOE (3,23)
7937 CCOF = SGTCOE (4,23)
7938 DCOF = SGTCOE (5,23)
7939 * | Compute the p p elastic cross section:
7940 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7942 * | Compute the K- p inelastic cross section:
7943 SPPINE = SPPTOT - SPPELA
7944 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7946 * | +----------------------------------------------------------------*
7948 IF ( ICHRGE (IP) .NE. 0 ) THEN
7950 * | | +-------------------------------------------------------------*
7951 * | | | Proton target:
7952 IF ( KHELP .EQ. 0 ) THEN
7953 * | | | Number of diagrams:
7957 * | | +-------------------------------------------------------------*
7958 * | | | Neutron target: it is supposed that (ap n)el is almost equal
7959 * | | | to (ap p)el (reasonable above 5 GeV/c)
7961 ACOF = SGTCOE (1,16)
7962 BCOF = SGTCOE (2,16)
7963 ENNE = SGTCOE (3,16)
7964 CCOF = SGTCOE (4,16)
7965 DCOF = SGTCOE (5,16)
7966 * | | | Compute the total cross section:
7967 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7969 * | | | Compute the elastic cross section:
7971 * | | | Compute the inelastic cross section:
7972 SHNCIN = SHNCTT - SHNCEL
7976 * | | +-------------------------------------------------------------*
7977 * | | Now compute the chain end (anti)quark-(anti)diquark
7978 * | | there are different possibilities, make a random choiche:
7980 RNCHEN = DT_RNDM(PUUBAR)
7981 IF ( RNCHEN .LT. PUUBAR ) THEN
7986 IQBSC1 = -IQFSC1 + KHELP
7989 * | +----------------------------------------------------------------*
7993 * | | +-------------------------------------------------------------*
7994 * | | | Proton target: (nbar p)in supposed to be given by
7995 * | | | (pbar p)in - Sig_diagr
7996 IF ( KHELP .EQ. 0 ) THEN
7997 SHNCIN = SAPPIN - SIGDIA
8000 * | | +-------------------------------------------------------------*
8001 * | | | Neutron target: (nbar n)el is supposed to be equal to
8002 * | | | (pbar p)el (reasonable above 5 GeV/c)
8004 * | | | Compute the total cross section:
8006 * | | | Compute the elastic cross section:
8008 * | | | Compute the inelastic cross section:
8009 SHNCIN = SHNCTT - SHNCEL
8013 * | | +-------------------------------------------------------------*
8014 * | | Now compute the chain end (anti)quark-(anti)diquark
8015 * | | there are different possibilities, make a random choiche:
8017 RNCHEN = DT_RNDM(RNCHEN)
8018 IF ( RNCHEN .LT. PDDBAR ) THEN
8023 IQBSC1 = -IQFSC1 + KHELP - 1
8027 * | +----------------------------------------------------------------*
8029 * +-------------------------------------------------------------------*
8030 * | Others: not yet implemented
8039 * +-------------------------------------------------------------------*
8040 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8041 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8043 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8047 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8049 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8050 & + IQSCHR (MQUARK(3,IP))
8051 * +-------------------------------------------------------------------*
8052 * | Consistency check:
8053 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8054 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8055 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8056 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8057 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8058 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8059 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8062 * +-------------------------------------------------------------------*
8063 * +-------------------------------------------------------------------*
8064 * | Consistency check:
8065 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8066 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8068 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8069 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8071 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8072 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8075 * +-------------------------------------------------------------------*
8076 * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8077 IF ( UMORAT .GT. ONEPLS )
8078 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8079 & - ONEONE ) * UMORAT + ONEONE )
8082 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8088 *=== End of function Phnsch ===========================================*
8092 *$ CREATE DT_RESPT.FOR
8095 *===respt==============================================================*
8099 ************************************************************************
8100 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8101 * This version dated 18.01.95 is written by S. Roesler *
8102 ************************************************************************
8104 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8106 PARAMETER ( LINP = 10 ,
8109 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8112 PARAMETER (NMXHKK=200000)
8113 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8114 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8115 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8116 * extended event history
8117 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8118 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8121 * get index of first chain
8122 DO 1 I=NPOINT(3),NHKK
8123 IF (IDHKK(I).EQ.88888) THEN
8130 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8131 C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8132 * skip VV-,SS- systems
8133 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8134 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8135 * check if both "chains" are resonances
8136 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8137 CALL DT_SAPTRE(NC,NC+3)
8151 *$ CREATE DT_EVTRES.FOR
8154 *===evtres=============================================================*
8156 SUBROUTINE DT_EVTRES(IREJ)
8158 ************************************************************************
8159 * This version dated 14.12.94 is written by S. Roesler *
8160 ************************************************************************
8162 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8164 PARAMETER ( LINP = 10 ,
8167 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8170 PARAMETER (NMXHKK=200000)
8171 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8172 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8173 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8174 * extended event history
8175 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8176 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8178 * flags for input different options
8179 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8180 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8181 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8182 * particle properties (BAMJET index convention)
8184 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8185 & IICH(210),IIBAR(210),K1(210),K2(210)
8187 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8191 DO 1 I=NPOINT(3),NHKK
8192 IF (ABS(IDRES(I)).GE.100) THEN
8194 DO 2 J=NPOINT(3),NHKK
8195 IF (IDHKK(J).EQ.88888) THEN
8196 IF (PHKK(5,J).GT.AMMX) THEN
8202 IF (IDRES(IMMX).NE.0) THEN
8203 IF (IOULEV(3).GT.0) THEN
8204 WRITE(LOUT,'(1X,A)')
8205 & 'EVTRES: no chain for correc. found'
8214 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8218 IMO21 = JMOHKK(1,IMMX)
8219 IMO22 = JMOHKK(2,IMMX)
8220 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8221 IMO21 = JMOHKK(2,IMMX)
8222 IMO22 = JMOHKK(1,IMMX)
8225 AMCH1N = AAM(IDXRES(I))
8227 IFPR1 = IDHKK(IMO11)
8228 IFPR2 = IDHKK(IMO21)
8229 IFTA1 = IDHKK(IMO12)
8230 IFTA2 = IDHKK(IMO22)
8232 PP1(J) = PHKK(J,IMO11)
8233 PP2(J) = PHKK(J,IMO21)
8234 PT1(J) = PHKK(J,IMO12)
8235 PT2(J) = PHKK(J,IMO22)
8237 * store initial configuration for energy-momentum cons. check
8238 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8239 * correct kinematics of second chain
8240 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8241 & AMCH1,AMCH1N,AMCH2,IREJ1)
8242 IF (IREJ1.NE.0) GOTO 9999
8243 * check now this chain for resonance mass
8244 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8246 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8247 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8249 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8251 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8252 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8253 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8254 & AMCH2,AMCH2N,IDCH2,IREJ1)
8255 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8257 & WRITE(LOUT,*) ' correction for resonance not poss.'
8263 * store final configuration for energy-momentum cons. check
8265 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8266 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8267 IF (IREJ1.NE.0) GOTO 9999
8270 PHKK(J,IMO11) = PP1(J)
8271 PHKK(J,IMO21) = PP2(J)
8272 PHKK(J,IMO12) = PT1(J)
8273 PHKK(J,IMO22) = PT2(J)
8275 * correct entries of chains
8277 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8278 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8280 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8281 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8283 * ?? the following should now be obsolete
8285 C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8286 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8288 WRITE(LOUT,'(1X,A,4G10.3)')
8289 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8293 PHKK(5,I) = SQRT(AM1)
8294 PHKK(5,IMMX) = SQRT(AM2)
8295 IDRES(I) = IDRES(I)/100
8296 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8297 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8298 WRITE(LOUT,'(1X,A,4G10.3)')
8299 & 'EVTRES: inconsistent chain-masses',
8300 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8313 *$ CREATE DT_GETSPT.FOR
8316 *===getspt=============================================================*
8318 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8319 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8320 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8322 ************************************************************************
8323 * This version dated 12.12.94 is written by S. Roesler *
8324 ************************************************************************
8326 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8328 PARAMETER ( LINP = 10 ,
8331 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8333 * various options for treatment of partons (DTUNUC 1.x)
8334 * (chain recombination, Cronin,..)
8335 LOGICAL LCO2CR,LINTPT
8336 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8338 * flags for input different options
8339 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8340 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8341 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8342 * flags for diffractive interactions (DTUNUC 1.x)
8343 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8345 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8346 & PT2(4),PT2I(4),P1(4),P2(4),
8347 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8348 & PTOTI(4),PTOTF(4),DIFF(4)
8354 C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8355 C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8361 IF (IDIFF.NE.0) THEN
8367 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8373 * get initial chain masses
8374 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8375 & +(PP1(3)+PT1(3))**2)
8377 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8378 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8379 & +(PP2(3)+PT2(3))**2)
8381 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8382 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8384 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8394 C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8398 C IF (AM1.LT.0.6) THEN
8400 C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8403 C IF (AM2.LT.0.6) THEN
8405 C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8410 * check chain masses for very low mass chains
8411 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8412 C & AM1,DUM,-IDCH1,IREJ1)
8413 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8414 C & AM2,DUM,-IDCH2,IREJ2)
8415 C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8424 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8425 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8426 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8427 C IF (MOD(IC,19).EQ.0) JMSHL = 0
8428 IF (MOD(IC,20).EQ.0) GOTO 7
8429 C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8434 * get transverse momentum
8436 ES = -2.0D0/(B33P**2)
8437 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8438 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8440 ES = -2.0D0/(B33T**2)
8441 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8442 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8448 CALL DT_DSFECF(SFE1,CFE1)
8449 CALL DT_DSFECF(SFE2,CFE2)
8451 PP1(1) = PP1I(1)+HPSP*CFE1
8452 PP1(2) = PP1I(2)+HPSP*SFE1
8453 PP2(1) = PP2I(1)-HPSP*CFE1
8454 PP2(2) = PP2I(2)-HPSP*SFE1
8455 PT1(1) = PT1I(1)+HPST*CFE2
8456 PT1(2) = PT1I(2)+HPST*SFE2
8457 PT2(1) = PT2I(1)-HPST*CFE2
8458 PT2(2) = PT2I(2)-HPST*SFE2
8460 PP1(1) = PP1I(1)+HPSP*CFE1
8461 PP1(2) = PP1I(2)+HPSP*SFE1
8462 PT1(1) = PT1I(1)-HPSP*CFE1
8463 PT1(2) = PT1I(2)-HPSP*SFE1
8464 PP2(1) = PP2I(1)+HPST*CFE2
8465 PP2(2) = PP2I(2)+HPST*SFE2
8466 PT2(1) = PT2I(1)-HPST*CFE2
8467 PT2(2) = PT2I(2)-HPST*SFE2
8470 * put partons on mass shell
8473 IF (JMSHL.EQ.1) THEN
8474 XMP1 = PYMASS(IFPR1)
8475 XMT1 = PYMASS(IFTA1)
8477 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8478 IF (IREJ1.NE.0) GOTO 2
8480 PTOTF(I) = P1(I)+P2(I)
8486 IF (JMSHL.EQ.1) THEN
8487 XMP2 = PYMASS(IFPR2)
8488 XMT2 = PYMASS(IFTA2)
8490 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8491 IF (IREJ1.NE.0) GOTO 2
8493 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8500 DIFF(I) = PTOTI(I)-PTOTF(I)
8502 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8503 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8504 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8507 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8508 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8509 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8510 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8511 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8512 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8513 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8514 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8515 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8516 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8518 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8519 & 'GETSPT: inconsistent masses',
8520 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8521 * sr 22.11.00: commented. It should only have inconsistent masses for
8522 * ultrahigh energies due to rounding problems
8527 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8528 & +(PP1(3)+PT1(3))**2)
8530 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
8531 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8532 & +(PP2(3)+PT2(3))**2)
8534 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
8535 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8537 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8544 * check chain masses for very low mass chains
8545 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8546 & AM1N,DUM,-IDCH1,IREJ1)
8547 IF (IREJ1.NE.0) GOTO 2
8548 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8549 & AM2N,DUM,-IDCH2,IREJ2)
8550 IF (IREJ2.NE.0) GOTO 2
8553 IF (AM1N.GT.ZERO) THEN
8571 *$ CREATE DT_SAPTRE.FOR
8574 *===saptre=============================================================*
8576 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8578 ************************************************************************
8579 * p-t sampling for two-resonance systems. ("BAMJET-like" method) *
8580 * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
8581 * Adopted from the original SAPTRE written by J. Ranft. *
8582 * This version dated 18.01.95 is written by S. Roesler *
8583 ************************************************************************
8585 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8587 PARAMETER ( LINP = 10 ,
8590 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8593 PARAMETER (NMXHKK=200000)
8594 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8595 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8596 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8597 * extended event history
8598 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8599 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8601 * flags for input different options
8602 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8603 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8604 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8606 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8610 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8611 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8612 ESMAX = MIN(ESMAX1,ESMAX2)
8613 IF (ESMAX.LE.0.05D0) RETURN
8617 PA1(K) = PHKK(K,IDX1)
8618 PA2(K) = PHKK(K,IDX2)
8622 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8623 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8627 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8628 BEXP = HMA*(1.0D0-EXEB)/B3
8629 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8630 WA = AXEXP/(BEXP+AXEXP)
8633 * ES is the transverse kinetic energy
8637 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8640 ES = ABS(-LOG(X+TINY7)/B3)
8642 IF (ES.GT.ESMAX) GOTO 10
8644 * transverse momentum
8645 HPS = SQRT((ES-HMA)*(ES+HMA))
8647 CALL DT_DSFECF(SFE,CFE)
8650 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8651 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8652 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8654 C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8655 C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8661 * put resonances on mass-shell again
8664 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8665 IF (IREJ1.NE.0) RETURN
8668 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8669 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8670 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8671 IF (IREJ1.NE.0) RETURN
8675 PHKK(K,IDX1) = P1(K)
8676 PHKK(K,IDX2) = P2(K)
8682 *$ CREATE DT_CRONIN.FOR
8685 *===cronin=============================================================*
8687 SUBROUTINE DT_CRONIN(INCL)
8689 ************************************************************************
8690 * Cronin-Effect. Multiple scattering of partons at chain ends. *
8691 * INCL = 1 multiple sc. in projectile *
8692 * = 2 multiple sc. in target *
8693 * This version dated 05.01.96 is written by S. Roesler. *
8694 ************************************************************************
8696 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8698 PARAMETER ( LINP = 10 ,
8701 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8704 PARAMETER (NMXHKK=200000)
8705 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8706 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8707 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8708 * extended event history
8709 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8710 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8713 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8714 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8715 & IREXCI(3),IRDIFF(2),IRINC
8716 * Glauber formalism: collision properties
8717 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8718 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8720 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8726 DO 2 I=NPOINT(2),NHKK
8727 IF (ISTHKK(I).LT.0) THEN
8728 * get z-position of the chain
8729 R(1) = VHKK(1,I)*1.0D12
8730 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8731 R(2) = VHKK(2,I)*1.0D12
8733 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8734 & IDXNU = JMOHKK(1,I-1)
8735 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8736 & IDXNU = JMOHKK(1,I+1)
8737 R(3) = VHKK(3,IDXNU)*1.0D12
8738 * position of target parton the chain is connected to
8742 * multiple scattering of parton with DTEVT1-index I
8743 CALL DT_CROMSC(PIN,R,POUT,INCL)
8745 C IF (NEVHKK.EQ.5) THEN
8746 C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8747 C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8748 C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8749 C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8750 C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8751 C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
8752 C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
8755 * increase accumulator by energy-momentum difference
8757 DEV(K) = DEV(K)+POUT(K)-PIN(K)
8760 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8761 & PHKK(2,I)**2-PHKK(3,I)**2))
8765 * dump accumulator to momenta of valence partons
8768 DO 5 I=NPOINT(2),NHKK
8769 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8771 ETOT = ETOT+PHKK(4,I)
8774 C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8775 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
8777 DO 6 I=NPOINT(2),NHKK
8778 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8781 C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8782 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8784 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8785 & PHKK(2,I)**2-PHKK(3,I)**2))
8792 *$ CREATE DT_CROMSC.FOR
8795 *===cromsc=============================================================*
8797 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8799 ************************************************************************
8800 * Cronin-Effect. Multiple scattering of one parton passing through *
8802 * PIN(4) input 4-momentum of parton *
8803 * POUT(4) 4-momentum of parton after mult. scatt. *
8804 * R(3) spatial position of parton in target nucleus *
8805 * INCL = 1 multiple sc. in projectile *
8806 * = 2 multiple sc. in target *
8807 * This is a revised version of the original version written by J. Ranft*
8808 * This version dated 17.01.95 is written by S. Roesler. *
8809 ************************************************************************
8811 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8813 PARAMETER ( LINP = 10 ,
8816 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8821 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8822 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8823 & IREXCI(3),IRDIFF(2),IRINC
8824 * Glauber formalism: collision properties
8825 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8826 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8827 * various options for treatment of partons (DTUNUC 1.x)
8828 * (chain recombination, Cronin,..)
8829 LOGICAL LCO2CR,LINTPT
8830 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8833 DIMENSION PIN(4),POUT(4),R(3)
8835 DATA LSTART /.TRUE./
8837 IRCRON(1) = IRCRON(1)+1
8840 WRITE(LOUT,1000) CRONCO
8841 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
8842 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8848 IF (INCL.EQ.2) RNCL = RTARG
8850 * Lorentz-transformation into Lab.
8852 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8854 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8855 IF (PTOT.LE.8.0D0) GOTO 9997
8857 * direction cosines of parton before mult. scattering
8862 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8863 IF (RTESQ.GE.-TINY3) GOTO 9999
8865 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8866 * in the direction of particle motion
8868 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8870 IF (TMP.LT.ZERO) GOTO 9998
8873 * multiple scattering angle
8874 THETO = CRONCO*SQRT(DIST)/PTOT
8875 IF (THETO.GT.0.1D0) THETO=0.1D0
8878 * Gaussian sampling of spatial angle
8879 CALL DT_RANNOR(R1,R2)
8880 THETA = ABS(R1*THETO)
8881 IF (THETA.GT.0.3D0) GOTO 9997
8882 CALL DT_DSFECF(SFE,CFE)
8886 * new direction cosines
8887 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8888 & COSXN,COSYN,COSZN)
8890 POUT(1) = COSXN*PTOT
8891 POUT(2) = COSYN*PTOT
8893 * Lorentz-transformation into nucl.-nucl. cms
8895 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8897 C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8898 C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8899 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8902 IF (MOD(NCBACK,200).EQ.0) THEN
8903 WRITE(LOUT,1001) THETO,PIN,POUT
8904 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8905 & E12.4,/,1X,' PIN :',4E12.4,/,
8906 & 1X,' POUT:',4E12.4)
8914 9997 IRCRON(2) = IRCRON(2)+1
8916 9998 IRCRON(3) = IRCRON(3)+1
8925 *$ CREATE DT_COM2CR.FOR
8928 *===com2sr=============================================================*
8930 SUBROUTINE DT_COM2CR
8932 ************************************************************************
8933 * COMbine q-aq chains to Color Ropes (qq-aqaq). *
8934 * CUTOF parameter determining minimum number of not *
8935 * combined q-aq chains *
8936 * This subroutine replaces KKEVCC etc. *
8937 * This version dated 11.01.95 is written by S. Roesler. *
8938 ************************************************************************
8940 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8942 PARAMETER ( LINP = 10 ,
8947 PARAMETER (NMXHKK=200000)
8948 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8949 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8950 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8951 * extended event history
8952 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8953 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8956 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8957 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8959 * various options for treatment of partons (DTUNUC 1.x)
8960 * (chain recombination, Cronin,..)
8961 LOGICAL LCO2CR,LINTPT
8962 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8965 DIMENSION IDXQA(248),IDXAQ(248)
8967 ICCHAI(1,9) = ICCHAI(1,9)+1
8970 * scan DTEVT1 for q-aq, aq-q chains
8971 DO 10 I=NPOINT(3),NHKK
8972 * skip "chains" which are resonances
8973 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8976 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8977 * q-aq, aq-q chain found, keep index
8978 IF (IDHKK(MO1).GT.0) THEN
8989 * minimum number of q-aq chains requested for the same projectile/
8991 NCHMIN = IDT_NPOISS(CUTOF)
8993 * combine q-aq chains of the same projectile
8994 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
8995 * combine q-aq chains of the same target
8996 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
8997 * combine aq-q chains of the same projectile
8998 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
8999 * combine aq-q chains of the same target
9000 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9005 *$ CREATE DT_SCN4CR.FOR
9008 *===scn4cr=============================================================*
9010 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9012 ************************************************************************
9013 * SCan q-aq chains for Color Ropes. *
9014 * This version dated 11.01.95 is written by S. Roesler. *
9015 ************************************************************************
9017 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9019 PARAMETER ( LINP = 10 ,
9024 PARAMETER (NMXHKK=200000)
9025 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9026 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9027 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9028 * extended event history
9029 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9030 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9033 DIMENSION IDXCH(248),IDXJN(248)
9036 IF (IDXCH(I).GT.0) THEN
9038 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9042 IF (IDXCH(J).GT.0) THEN
9043 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9044 IF (IDXMO.EQ.IDXMO1) THEN
9051 IF (NJOIN.GE.NCHMIN+2) THEN
9052 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9054 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9055 IF (IREJ1.NE.0) GOTO 3
9057 IDXCH(IDXJN(J+1)) = 0
9066 *$ CREATE DT_JOIN.FOR
9069 *===join===============================================================*
9071 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9073 ************************************************************************
9074 * This subroutine joins two q-aq chains to one qq-aqaq chain. *
9075 * IDX1, IDX2 DTEVT1 indices of chains to be joined *
9076 * This version dated 11.01.95 is written by S. Roesler. *
9077 ************************************************************************
9079 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9081 PARAMETER ( LINP = 10 ,
9086 PARAMETER (NMXHKK=200000)
9087 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9088 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9089 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9090 * extended event history
9091 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9092 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9094 * flags for input different options
9095 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9096 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9097 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9099 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9100 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9103 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9111 MO(I,J) = JMOHKK(J,IDX(I))
9112 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9117 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9118 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9119 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9120 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9121 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9123 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9124 & 2I5,' chain ',I4,':',2I5)
9129 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9130 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9132 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9133 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9134 IST1 = ISTHKK(MO(1,1))
9135 IST2 = ISTHKK(MO(1,2))
9137 * put partons again on mass shell
9140 IF (IMSHL.EQ.1) THEN
9144 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9145 IF (IREJ1.NE.0) GOTO 9999
9151 * store new partons in DTEVT1
9152 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9154 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9157 PCH(K) = PP(K)+PT(K)
9160 * check new chain for lower mass limit
9161 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9162 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9163 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9164 & AMCH,AMCHN,3,IREJ1)
9165 IF (IREJ1.NE.0) THEN
9171 ICCHAI(2,9) = ICCHAI(2,9)+1
9172 * store new chain in DTEVT1
9174 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9175 IDHKK(IDX(1)) = 22222
9176 IDHKK(IDX(2)) = 22222
9177 * special treatment for space-time coordinates
9179 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9180 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9189 *$ CREATE DT_XSGLAU.FOR
9192 *===xsglau=============================================================*
9194 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9196 ************************************************************************
9197 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9198 * Glauber's approach. *
9199 * NA / NB mass numbers of proj./target nuclei *
9200 * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9201 * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9202 * IE,IQ indices of energy and virtuality (the latter for gamma *
9203 * projectiles only) *
9204 * NIDX index of projectile/target nucleus *
9205 * This version dated 17.3.98 is written by S. Roesler *
9206 ************************************************************************
9208 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9210 PARAMETER ( LINP = 10 ,
9214 COMPLEX*16 CZERO,CONE,CTWO
9216 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9217 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9218 PARAMETER (TWOPI = 6.283185307179586454D+00,
9220 & GEV2MB = 0.38938D0,
9221 & GEV2FM = 0.1972D0,
9222 & ALPHEM = ONE/137.0D0,
9226 * approx. nucleon radius
9229 * particle properties (BAMJET index convention)
9231 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9232 & IICH(210),IIBAR(210),K1(210),K2(210)
9233 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9234 PARAMETER ( MAXNCL = 260,
9236 & MAXSQU = 20*MAXVQU,
9237 & MAXINT = MAXVQU+MAXSQU)
9238 * Glauber formalism: parameters
9239 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9240 & BMAX(NCOMPX),BSTEP(NCOMPX),
9241 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9243 * Glauber formalism: cross sections
9244 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9245 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9246 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9247 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9248 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9249 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9250 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9251 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9252 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9253 & BSLOPE,NEBINI,NQBINI
9254 * Glauber formalism: flags and parameters for statistics
9257 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9258 * nucleon-nucleon event-generator
9261 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9262 * VDM parameter for photon-nucleus interactions
9263 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9264 * parameters for hA-diffraction
9265 COMMON /DTDIHA/ DIBETA,DIALPH
9267 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9268 & OMPP11,OMPP12,OMPP21,OMPP22,
9269 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9272 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9273 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9276 PARAMETER (NPOINT=16)
9277 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9279 LOGICAL LFIRST,LOPEN
9280 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9283 * for quasi-elastic neutrino scattering set projectile to proton
9284 * it should not have an effect since the whole Glauber-formalism is
9285 * not needed for these interactions..
9286 IF (MCGENE.EQ.4) THEN
9292 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9295 CFILE = CGLB//'.glb'
9296 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9297 ELSEIF (I.GT.1) THEN
9298 CFILE = CGLB(1:I-1)//'.glb'
9299 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9306 CZERO = DCMPLX(ZERO,ZERO)
9307 CONE = DCMPLX(ONE,ZERO)
9308 CTWO = DCMPLX(TWO,ZERO)
9312 * re-define kinematics
9316 * g(Q2=0)-A, h-A, A-A scattering
9317 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9320 * g(Q2>0)-A scattering
9321 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9323 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9324 Q2 = (S-AMP2)*X/(ONE-X)
9325 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9326 S = Q2*(ONE-X)/X+AMP2
9328 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9333 XNU = (S+Q2-AMP2)/(TWO*AMP)
9335 * parameters determining statistics in evaluating Glauber-xsection
9338 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9340 * set up interaction geometry (common /DTGLAM/)
9341 * projectile/target radii
9342 RPRNCL = DT_RNCLUS(NA)
9343 RTANCL = DT_RNCLUS(NB)
9344 IF (IJPROJ.EQ.7) THEN
9346 RBSH(NTARG) = RTANCL
9347 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9349 IF (NIDX.LE.-1) THEN
9351 RBSH(NTARG) = RTANCL
9352 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9354 RASH(NTARG) = RPRNCL
9356 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9359 * maximum impact-parameter
9360 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9362 * slope, rho ( Re(f(0))/Im(f(0)) )
9363 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9364 IF (MCGENE.EQ.2) THEN
9366 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9369 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9371 IF (ECMNN(IE).LE.3.0D0) THEN
9373 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9374 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9375 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9378 ELSEIF (IJPROJ.EQ.7) THEN
9381 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9385 * projectile-nucleon xsection (in fm)
9386 IF (IJPROJ.EQ.7) THEN
9387 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9389 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9390 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9391 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9393 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9394 SIGSH = SIGSH/10.0D0
9397 * parameters for projectile diffraction (hA scattering only)
9398 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9399 & .AND.(DIBETA.GE.ZERO)) THEN
9401 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9402 C DIBETA = SDIF1/STOT
9404 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9405 IF (DIBETA.LE.ZERO) THEN
9408 ALPGAM = DIALPH/DIGAMM
9412 FACDI = SQRT(FACDI1*FACDI2)
9413 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9425 BSITE( 0,IQ,NTARG,I) = ZERO
9426 BSITE(IE,IQ,NTARG,I) = ZERO
9445 FACN = ONE/DBLE(NSTATB)
9450 * initialize Gauss-integration for photon-proj.
9452 IF (IJPROJ.EQ.7) THEN
9453 IF (INTRGE(1).EQ.1) THEN
9454 AMLO2 = (3.0D0*AAM(13))**2
9455 ELSEIF (INTRGE(1).EQ.2) THEN
9460 IF (INTRGE(2).EQ.1) THEN
9462 ELSEIF (INTRGE(2).EQ.2) THEN
9467 AMHI20 = (ECMNN(IE)-AMP)**2
9468 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9469 XAMLO = LOG( AMLO2+Q2 )
9470 XAMHI = LOG( AMHI2+Q2 )
9472 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9474 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9477 * ratio direct/total photon-nucleon xsection
9478 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9481 * read pre-initialized profile-function from file
9482 IF (IOGLB.EQ.1) THEN
9483 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9484 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9485 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9486 & NA,NB,NSTATB,NSITEB
9487 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9488 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9489 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
9492 IF (LFIRST) WRITE(LOUT,1001) CFILE
9493 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9495 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9496 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9497 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9498 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9499 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9500 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9501 NLINES = INT(DBLE(NSITEB)/7.0D0)
9502 IF (NLINES.GT.0) THEN
9505 READ(LDAT,'(7E11.4)')
9506 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9510 IF (ISTART.LE.NSITEB) THEN
9511 READ(LDAT,'(7E11.4)')
9512 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9516 * variable projectile/target/energy runs:
9517 * read pre-initialized profile-functions from file
9518 ELSEIF (IOGLB.EQ.100) THEN
9519 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9523 * cross sections averaged over NSTATB nucleon configurations
9525 C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9535 IF (NIDX.LE.-1) THEN
9536 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9537 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9538 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9539 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9540 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9543 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9544 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9545 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9546 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9547 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9551 * integration over impact parameter B
9562 B = DBLE(IB)*BSTEP(NTARG)
9563 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
9565 * integration over M_V^2 for photon-proj.
9571 IF (IJPROJ.EQ.7) THEN
9583 IF (IJPROJ.EQ.7) THEN
9584 AMV2 = EXP(ABSZX(IM))-Q2
9586 IF (AMV2.LT.16.0D0) THEN
9588 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9593 * define M_V dependent properties of nucleon scattering amplitude
9594 * V_M-nucleon xsection
9595 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9596 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9597 * slope-parametrisation a la Kaidalov
9598 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9599 & +0.25D0*LOG(S/(AMV2+Q2)))
9601 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9602 * integration weight factor
9603 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9604 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9606 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9608 IF (IJPROJ.EQ.7) THEN
9609 RCA = GAM*SIGMV/TWOPI
9611 RCA = GAM*SIGSH/TWOPI
9614 CA = DCMPLX(RCA,FCA)
9623 * photon-projectile: check for supression by coherence length
9624 IF (IJPROJ.EQ.7) THEN
9625 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9629 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9635 X11 = B+COOT1(1,INB)-COOP1(1,INA)
9636 Y11 = COOT1(2,INB)-COOP1(2,INA)
9637 XY11 = GAM*(X11*X11+Y11*Y11)
9638 IF (XY11.LE.15.0D0) THEN
9639 C = CONE-CA*EXP(-XY11)
9640 AR = DBLE(PP11(INT1))
9641 AI = DIMAG(PP11(INT1))
9642 IF (ABS(AR).LT.TINY25) AR = ZERO
9643 IF (ABS(AI).LT.TINY25) AI = ZERO
9644 PP11(INT1) = DCMPLX(AR,AI)
9645 PP11(INT1) = PP11(INT1)*C
9648 SHI = SHI+LOG(AR*AR+AI*AI)
9650 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9651 X12 = B+COOT2(1,INB)-COOP1(1,INA)
9652 Y12 = COOT2(2,INB)-COOP1(2,INA)
9653 XY12 = GAM*(X12*X12+Y12*Y12)
9654 IF (XY12.LE.15.0D0) THEN
9655 C = CONE-CA*EXP(-XY12)
9656 AR = DBLE(PP12(INT2))
9657 AI = DIMAG(PP12(INT2))
9658 IF (ABS(AR).LT.TINY25) AR = ZERO
9659 IF (ABS(AI).LT.TINY25) AI = ZERO
9660 PP12(INT2) = DCMPLX(AR,AI)
9661 PP12(INT2) = PP12(INT2)*C
9663 X21 = B+COOT1(1,INB)-COOP2(1,INA)
9664 Y21 = COOT1(2,INB)-COOP2(2,INA)
9665 XY21 = GAM*(X21*X21+Y21*Y21)
9666 IF (XY21.LE.15.0D0) THEN
9667 C = CONE-CA*EXP(-XY21)
9668 AR = DBLE(PP21(INT1))
9669 AI = DIMAG(PP21(INT1))
9670 IF (ABS(AR).LT.TINY25) AR = ZERO
9671 IF (ABS(AI).LT.TINY25) AI = ZERO
9672 PP21(INT1) = DCMPLX(AR,AI)
9673 PP21(INT1) = PP21(INT1)*C
9675 X22 = B+COOT2(1,INB)-COOP2(1,INA)
9676 Y22 = COOT2(2,INB)-COOP2(2,INA)
9677 XY22 = GAM*(X22*X22+Y22*Y22)
9678 IF (XY22.LE.15.0D0) THEN
9679 C = CONE-CA*EXP(-XY22)
9680 AR = DBLE(PP22(INT2))
9681 AI = DIMAG(PP22(INT2))
9682 IF (ABS(AR).LT.TINY25) AR = ZERO
9683 IF (ABS(AI).LT.TINY25) AI = ZERO
9684 PP22(INT2) = DCMPLX(AR,AI)
9685 PP22(INT2) = PP22(INT2)*C
9696 IF (PP11(K).EQ.CZERO) THEN
9700 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9701 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9704 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9705 OMPP11 = OMPP11+AVDIPP
9706 C OMPP11 = OMPP11+(CONE-PP11(K))
9707 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9708 DIPP11 = DIPP11+AVDIPP
9709 IF (PP21(K).EQ.CZERO) THEN
9713 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9714 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9717 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9718 OMPP21 = OMPP21+AVDIPP
9719 C OMPP21 = OMPP21+(CONE-PP21(K))
9720 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9721 DIPP21 = DIPP21+AVDIPP
9728 IF (PP12(K).EQ.CZERO) THEN
9732 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9733 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9736 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9737 OMPP12 = OMPP12+AVDIPP
9738 C OMPP12 = OMPP12+(CONE-PP12(K))
9739 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9740 DIPP12 = DIPP12+AVDIPP
9741 IF (PP22(K).EQ.CZERO) THEN
9745 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9746 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9749 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9750 OMPP22 = OMPP22+AVDIPP
9751 C OMPP22 = OMPP22+(CONE-PP22(K))
9752 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9753 DIPP22 = DIPP22+AVDIPP
9756 SPROM = ONE-EXP(SHI)
9757 SPROB = SPROB+FACM*SPROM
9758 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9759 STOTM = DBLE(OMPP11+OMPP22)
9760 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9761 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9762 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9763 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9764 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9765 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9766 STOTB = STOTB+FACM*STOTM
9767 SELAB = SELAB+FACM*SELAM
9768 SDELB = SDELB+FACM*SDELM
9770 SQEPB = SQEPB+FACM*SQEPM
9771 SDQEB = SDQEB+FACM*SDQEM
9773 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9774 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9775 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9780 STOTN = STOTN+FACB*STOTB
9781 SELAN = SELAN+FACB*SELAB
9782 SQEPN = SQEPN+FACB*SQEPB
9783 SQETN = SQETN+FACB*SQETB
9784 SQE2N = SQE2N+FACB*SQE2B
9785 SPRON = SPRON+FACB*SPROB
9786 SDELN = SDELN+FACB*SDELB
9787 SDQEN = SDQEN+FACB*SDQEB
9789 IF (IJPROJ.EQ.7) THEN
9790 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9792 IF (DIBETA.GT.ZERO) THEN
9793 BPROD(IB+1)= BPROD(IB+1)
9794 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9796 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9802 STOT = STOT +FACN*STOTN
9803 STOT2 = STOT2+FACN*STOTN**2
9804 SELA = SELA +FACN*SELAN
9805 SELA2 = SELA2+FACN*SELAN**2
9806 SQEP = SQEP +FACN*SQEPN
9807 SQEP2 = SQEP2+FACN*SQEPN**2
9808 SQET = SQET +FACN*SQETN
9809 SQET2 = SQET2+FACN*SQETN**2
9810 SQE2 = SQE2 +FACN*SQE2N
9811 SQE22 = SQE22+FACN*SQE2N**2
9812 SPRO = SPRO +FACN*SPRON
9813 SPRO2 = SPRO2+FACN*SPRON**2
9814 SDEL = SDEL +FACN*SDELN
9815 SDEL2 = SDEL2+FACN*SDELN**2
9816 SDQE = SDQE +FACN*SDQEN
9817 SDQE2 = SDQE2+FACN*SDQEN**2
9821 * final cross sections
9823 XSTOT(IE,IQ,NTARG) = STOT
9825 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9827 XSELA(IE,IQ,NTARG) = SELA
9828 * 3) quasi-el.: A+B-->A+X (excluding 2)
9829 XSQEP(IE,IQ,NTARG) = SQEP
9830 * 4) quasi-el.: A+B-->X+B (excluding 2)
9831 XSQET(IE,IQ,NTARG) = SQET
9832 * 5) quasi-el.: A+B-->X (excluding 2-4)
9833 XSQE2(IE,IQ,NTARG) = SQE2
9834 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9835 IF (SDEL.GT.ZERO) THEN
9836 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9838 XSPRO(IE,IQ,NTARG) = SPRO
9840 * 7) projectile diffraction (el. scatt. off target)
9841 XSDEL(IE,IQ,NTARG) = SDEL
9842 * 8) projectile diffraction (quasi-el. scatt. off target)
9843 XSDQE(IE,IQ,NTARG) = SDQE
9845 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9846 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9847 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9848 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9849 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9850 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9851 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9852 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9854 IF (IJPROJ.EQ.7) THEN
9855 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9856 & -XSQEP(IE,IQ,NTARG)
9858 BNORM = XSPRO(IE,IQ,NTARG)
9861 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9862 IF ((IE.EQ.1).AND.(IQ.EQ.1))
9863 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9866 * write profile function data into file
9867 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9868 WRITE(LDAT,'(5I10,1P,E15.5)')
9869 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9870 WRITE(LDAT,'(1P,6E12.5)')
9871 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9872 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9873 WRITE(LDAT,'(1P,6E12.5)')
9874 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9875 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9876 NLINES = INT(DBLE(NSITEB)/7.0D0)
9877 IF (NLINES.GT.0) THEN
9880 WRITE(LDAT,'(1P,7E11.4)')
9881 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9885 IF (ISTART.LE.NSITEB) THEN
9886 WRITE(LDAT,'(1P,7E11.4)')
9887 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9893 C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9898 *$ CREATE DT_GETBXS.FOR
9901 *===getbxs=============================================================*
9903 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9905 ************************************************************************
9906 * Biasing in impact parameter space. *
9907 * XSFRAC = 0 : BLO - minimum impact parameter (input) *
9908 * BHI - maximum impact parameter (input) *
9909 * XSFRAC - fraction of cross section corresponding *
9910 * to impact parameter range (BLO,BHI) *
9912 * XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
9913 * BHI - maximum impact parameter giving requested *
9914 * fraction of cross section in impact *
9915 * parameter range (0,BMAX) (output) *
9916 * This version dated 17.03.00 is written by S. Roesler *
9917 ************************************************************************
9919 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9921 PARAMETER ( LINP = 10 ,
9925 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9926 * Glauber formalism: parameters
9927 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9928 & BMAX(NCOMPX),BSTEP(NCOMPX),
9929 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9933 IF (XSFRAC.LE.0.0D0) THEN
9934 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9935 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9936 IF (ILO.GE.IHI) THEN
9940 IF (ILO.EQ.NSITEB-1) THEN
9941 FRCLO = BSITE(0,1,NTARG,NSITEB)
9943 FRCLO = BSITE(0,1,NTARG,ILO+1)
9944 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9945 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9947 IF (IHI.EQ.NSITEB-1) THEN
9948 FRCHI = BSITE(0,1,NTARG,NSITEB)
9950 FRCHI = BSITE(0,1,NTARG,IHI+1)
9951 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9952 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9954 XSFRAC = FRCHI-FRCLO
9959 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9960 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
9961 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9962 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9972 *$ CREATE DT_CONUCL.FOR
9975 *===conucl=============================================================*
9977 SUBROUTINE DT_CONUCL(X,N,R,MODE)
9979 ************************************************************************
9980 * Calculation of coordinates of nucleons within nuclei. *
9981 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
9982 * N / R number of nucleons / radius of nucleus (input) *
9983 * MODE = 0 coordinates not sorted *
9984 * = 1 coordinates sorted with increasing X(3,i) *
9985 * = 2 coordinates sorted with decreasing X(3,i) *
9986 * This version dated 26.10.95 is revised by S. Roesler *
9987 ************************************************************************
9989 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9991 PARAMETER ( LINP = 10 ,
9995 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9996 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
9998 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10000 PARAMETER (NSRT=10)
10001 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10002 DIMENSION X(3,N),XTMP(3,260)
10004 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10006 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10009 IF (MODE.EQ.2) THEN
10015 DO 2 J=1,ICSRT(ISRT)
10017 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10018 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10019 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10021 IF (ICSRT(ISRT).GT.1) THEN
10024 CALL DT_SORT(X,N,I0,I1,MODE)
10027 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10033 CALL DT_SORT(X,N,1,N,MODE)
10045 *$ CREATE DT_COORDI.FOR
10048 *===coordi=============================================================*
10050 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10052 ************************************************************************
10053 * Calculation of coordinates of nucleons within nuclei. *
10054 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
10055 * N / R number of nucleons / radius of nucleus (input) *
10056 * Based on the original version by Shmakov et al. *
10057 * This version dated 26.10.95 is revised by S. Roesler *
10058 ************************************************************************
10060 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10062 PARAMETER ( LINP = 10 ,
10066 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10067 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10069 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10073 PARAMETER (NSRT=10)
10074 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10075 DIMENSION X(3,260),WD(4),RD(3)
10077 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10078 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10079 DATA RD /2.09D0, 0.935D0, 0.697D0/
10089 ELSEIF (N.EQ.2) THEN
10090 EPS = DT_RNDM(RD(1))
10092 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10096 CALL DT_RANNOR(X1,X2)
10100 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10103 CALL DT_RANNOR(X3,X4)
10105 CALL DT_RANNOR(X1,X2)
10108 IF (LSTART) GOTO 80
10110 CALL DT_RANNOR(X3,X4)
10115 LSTART = .NOT.LSTART
10116 X1SUM = X1SUM+X(1,I)
10117 X2SUM = X2SUM+X(2,I)
10118 X3SUM = X3SUM+X(3,I)
10120 X1SUM = X1SUM/DBLE(N)
10121 X2SUM = X2SUM/DBLE(N)
10122 X3SUM = X3SUM/DBLE(N)
10124 X(1,I) = X(1,I)-X1SUM
10125 X(2,I) = X(2,I)-X2SUM
10126 X(3,I) = X(3,I)-X3SUM
10130 * maximum nuclear radius for coordinate sampling
10131 RMAX = R+4.605D0*PDIF
10133 * initialize pre-sorting
10137 DR = TWO*RMAX/DBLE(NSRT)
10139 * sample coordinates for N nucleons
10142 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10143 F = DT_DENSIT(N,RAD,R)
10144 IF (DT_RNDM(RAD).GT.F) GOTO 120
10145 * theta, phi uniformly distributed
10146 CT = ONE-TWO*DT_RNDM(F)
10147 ST = SQRT((ONE-CT)*(ONE+CT))
10148 CALL DT_DSFECF(SFE,CFE)
10149 X(1,I) = RAD*ST*CFE
10150 X(2,I) = RAD*ST*SFE
10152 * ensure that distance between two nucleons is greater than R2MIN
10153 IF (I.LT.2) GOTO 122
10156 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10157 & (X(3,I)-X(3,I2))**2
10158 IF (DIST2.LE.R2MIN) GOTO 120
10161 * save index according to z-bin
10162 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10163 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10164 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10165 X1SUM = X1SUM+X(1,I)
10166 X2SUM = X2SUM+X(2,I)
10167 X3SUM = X3SUM+X(3,I)
10169 X1SUM = X1SUM/DBLE(N)
10170 X2SUM = X2SUM/DBLE(N)
10171 X3SUM = X3SUM/DBLE(N)
10173 X(1,I) = X(1,I)-X1SUM
10174 X(2,I) = X(2,I)-X2SUM
10175 X(3,I) = X(3,I)-X3SUM
10183 *$ CREATE DT_DENSIT.FOR
10186 *===densit=============================================================*
10188 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10190 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10193 PARAMETER ( LINP = 10 ,
10196 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10197 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10200 DIMENSION R0(18),FNORM(18)
10201 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10202 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10203 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10204 & 2.72D0, 2.66D0, 2.79D0/
10205 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10206 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10207 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10208 & .1214D+01,.1265D+01,.1318D+01/
10209 DATA PDIF /0.545D0/
10215 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10216 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10217 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10218 & *EXP(-(R/R1)**2)/FNORM(NA)
10220 ELSEIF (NA.GT.18) THEN
10221 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10227 *$ CREATE DT_RNCLUS.FOR
10230 *===rnclus=============================================================*
10232 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10234 ************************************************************************
10235 * Nuclear radius for nucleus with mass number N. *
10236 * This version dated 26.9.00 is written by S. Roesler *
10237 ************************************************************************
10239 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10242 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10245 PARAMETER (RNUCLE = 1.12D0)
10247 * nuclear radii for selected nuclei
10248 DIMENSION RADNUC(18)
10249 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10250 & 2.58D0,2.71D0,2.66D0,2.71D0/
10253 IF (RADNUC(N).GT.0.0D0) THEN
10254 DT_RNCLUS = RADNUC(N)
10256 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10259 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10265 *$ CREATE DT_DENTST.FOR
10268 *===dentst=============================================================*
10270 C PROGRAM DT_DENTST
10271 SUBROUTINE DT_DENTST
10273 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10276 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10277 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10282 DR = (RMAX-RMIN)/DBLE(NBINS)
10286 R = RMIN+DBLE(IR-1)*DR
10287 F = DT_DENSIT(IA,R,R)
10288 IF (F.GT.FMAX) FMAX = F
10289 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10291 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10299 *$ CREATE DT_SHMAKI.FOR
10302 *===shmaki=============================================================*
10304 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10306 ************************************************************************
10307 * Initialisation of Glauber formalism. This subroutine has to be *
10308 * called once (in case of target emulsions as often as many different *
10309 * target nuclei are considered) before events are sampled. *
10310 * NA / NCA mass number/charge of projectile nucleus *
10311 * NB / NCB mass number/charge of target nucleus *
10312 * IJP identity of projectile (hadrons/leptons/photons) *
10313 * PPN projectile momentum (for projectile nuclei: *
10314 * momentum per nucleon) in target rest system *
10315 * MODE = 0 Glauber formalism invoked *
10316 * = 1 fitted results are loaded from data-file *
10317 * = 99 NTARG is forced to be 1 *
10318 * (used in connection with GLAUBERI-card only) *
10319 * This version dated 22.03.96 is based on the original SHMAKI-routine *
10320 * and revised by S. Roesler. *
10321 ************************************************************************
10323 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10325 PARAMETER ( LINP = 10 ,
10328 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10331 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10332 * Glauber formalism: parameters
10333 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10334 & BMAX(NCOMPX),BSTEP(NCOMPX),
10335 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10337 * Lorentz-parameters of the current interaction
10338 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10339 & UMO,PPCM,EPROJ,PPROJ
10340 * properties of photon/lepton projectiles
10341 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10342 * kinematical cuts for lepton-nucleus interactions
10343 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10344 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10345 * Glauber formalism: cross sections
10346 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10347 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10348 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10349 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10350 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10351 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10352 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10353 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10354 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10355 & BSLOPE,NEBINI,NQBINI
10356 * cuts for variable energy runs
10357 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10358 * nucleon-nucleon event-generator
10361 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10362 * Glauber formalism: flags and parameters for statistics
10365 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10367 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10373 IF (MODE.EQ.99) NTARG = 1
10375 IF (MODE.EQ.-1) NIDX = NTARG
10377 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10378 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10379 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10380 & ' initialization',/,12X,'--------------------------',
10381 & '-------------------------',/)
10383 IF (MODE.EQ.2) THEN
10384 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10385 CALL DT_SHFAST(MODE,PPN,IBACK)
10386 STOP ' Glauber pre-initialization done'
10388 IF (MODE.EQ.1) THEN
10389 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10392 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10393 IF (IBACK.EQ.1) THEN
10394 * lepton-nucleus (variable energy runs)
10395 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10396 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10397 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10398 & WRITE(LOUT,1002) NB,NCB
10399 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10400 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10401 & 'E_cm (GeV) Q^2 (GeV^2)',
10402 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10403 & '--------------------------------',
10404 & '------------------------------')
10405 AECMLO = LOG10(MIN(UMO,ECMLI))
10406 AECMHI = LOG10(MIN(UMO,ECMHI))
10408 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10409 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10411 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10412 IF (Q2HI.GT.0.1D0) THEN
10413 IF (Q2LI.LT.0.01D0) THEN
10414 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10415 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10417 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10424 AQ2LO = LOG10(Q2LI)
10425 AQ2HI = LOG10(Q2HI)
10426 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10427 DO 2 J=IBIN,IQSTEP+IBIN
10428 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10429 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10430 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10431 & WRITE(LOUT,1003) ECMNN(I),
10432 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10435 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10436 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10438 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10440 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10444 * hadron/photon/nucleus-nucleus
10445 IF ((ABS(VAREHI).GT.ZERO).AND.
10446 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10447 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10448 WRITE(LOUT,1004) NA,NB,NCB
10449 1004 FORMAT(1X,'variable energy run: projectile-id:',
10450 & I3,' target A/Z: ',I3,' /',I3,/)
10452 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10453 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10454 & ' -------------------------------------',
10455 & '--------------------------------------')
10457 AECMLO = LOG10(VARCLO)
10458 AECMHI = LOG10(VARCHI)
10460 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10461 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10463 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10468 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10469 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10470 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10471 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10473 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10474 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10478 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10484 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10485 & (IOGLB.NE.100)) THEN
10486 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10487 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10488 1001 FORMAT(38X,'projectile',
10489 & ' target',/,1X,'Mass number / charge',
10490 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10491 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10492 & 'Parameters of elastic scattering amplitude:',/,5X,
10493 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10494 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10495 & 'statistics at each b-step',4X,I5,/,/,1X,
10496 & 'Prod. cross section ',5X,F10.4,' mb',/)
10502 *$ CREATE DT_PROFBI.FOR
10505 *===profbi=============================================================*
10507 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10509 ************************************************************************
10510 * Integral over profile function (to be used for impact-parameter *
10511 * sampling during event generation). *
10512 * Fitted results are used. *
10513 * NA / NB mass numbers of proj./target nuclei *
10514 * PPN projectile momentum (for projectile nuclei: *
10515 * momentum per nucleon) in target rest system *
10516 * NTARG index of target material (i.e. kind of nucleus) *
10517 * This version dated 31.05.95 is revised by S. Roesler *
10518 ************************************************************************
10520 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10522 PARAMETER ( LINP = 10 ,
10527 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10532 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10533 * Glauber formalism: parameters
10534 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10535 & BMAX(NCOMPX),BSTEP(NCOMPX),
10536 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10538 * Glauber formalism: cross sections
10539 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10540 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10541 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10542 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10543 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10544 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10545 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10546 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10547 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10548 & BSLOPE,NEBINI,NQBINI
10550 PARAMETER (NGLMAX=8000)
10551 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10552 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10554 DATA LSTART /.TRUE./
10557 * read fit-parameters from file
10558 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10561 READ(47,'(A80)') CNAME
10562 IF (CNAME.EQ.'STOP') GOTO 2
10564 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10565 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10566 & GLAFIT(4,I),GLAFIT(5,I)
10567 IF (I+1.GT.NGLMAX) THEN
10569 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
10570 & 'program stopped')
10587 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10588 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10591 IF (J.EQ.NGLPAR) IPOINT = J+1-K
10592 IF ((NNA.GT.NGLIP(IPOINT)).OR.
10593 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10594 IF (IPOINT.EQ.1) IPOINT = 0
10595 NATMP = NGLIP(IPOINT+1)
10596 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10602 C IF (J.EQ.NGLPAR) THEN
10606 DO 5 J1=J1BEG,J1END
10607 IF (NGLIP(J1).EQ.NATMP) THEN
10608 IF (PPN.LT.GLAPPN(J1)) THEN
10617 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10626 IF (IDXGLA.EQ.0) THEN
10627 WRITE(LOUT,1001) NNA,NNB,PPN
10628 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
10629 & 2I4,F6.0,') not found ')
10633 * no interpolation yet available
10634 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10636 BSITE(1,1,NTARG,1) = ZERO
10639 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10640 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10641 & GLAFIT(5,IDXGLA)*XX**4
10642 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10643 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10644 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10650 *$ CREATE DT_GLAUBE.FOR
10653 *===glaube=============================================================*
10655 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10657 ************************************************************************
10658 * Calculation of configuartion of interacting nucleons for one event. *
10659 * NB / NB mass numbers of proj./target nuclei (input) *
10660 * B impact parameter (output) *
10661 * INTT total number of wounded nucleons " *
10662 * INTA / INTB number of wounded nucleons in proj. / target " *
10663 * JS / JT(i) number of collisions proj. / target nucleon i is *
10664 * involved (output) *
10665 * NIDX index of projectile/target material (input) *
10666 * = -2 call within FLUKA transport calculation *
10667 * This is an update of the original routine SHMAKO by J.Ranft/HJM *
10668 * This version dated 22.03.96 is revised by S. Roesler *
10670 * Last change 27.12.2006 by S. Roesler. *
10671 ************************************************************************
10673 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10675 PARAMETER ( LINP = 10 ,
10678 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10679 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10681 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10682 PARAMETER ( MAXNCL = 260,
10684 & MAXSQU = 20*MAXVQU,
10685 & MAXINT = MAXVQU+MAXSQU)
10686 * Glauber formalism: parameters
10687 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10688 & BMAX(NCOMPX),BSTEP(NCOMPX),
10689 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10691 * Glauber formalism: cross sections
10692 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10693 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10694 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10695 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10696 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10697 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10698 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10699 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10700 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10701 & BSLOPE,NEBINI,NQBINI
10702 * Lorentz-parameters of the current interaction
10703 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10704 & UMO,PPCM,EPROJ,PPROJ
10705 * properties of photon/lepton projectiles
10706 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10707 * Glauber formalism: collision properties
10708 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10709 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10710 * Glauber formalism: flags and parameters for statistics
10713 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10715 DIMENSION JS(MAXNCL),JT(MAXNCL)
10719 * get actual energy from /DTLTRA/
10723 * new patch for pre-initialized variable projectile/target/energy runs,
10724 * bypassed for use within FLUKA (Nidx=-2)
10725 IF (IOGLB.EQ.100) THEN
10726 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10728 * variable energy run, interpolate profile function
10733 IF (NEBINI.GT.1) THEN
10734 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10738 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10740 IF (ECMNOW.LT.ECMNN(I)) THEN
10743 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10753 IF (NQBINI.GT.1) THEN
10754 IF (Q2.GE.Q2G(NQBINI)) THEN
10758 ELSEIF (Q2.GT.Q2G(1)) THEN
10760 IF (Q2.LT.Q2G(I)) THEN
10763 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
10764 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10765 C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10774 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10775 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10776 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10777 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10778 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10782 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10783 IF (NIDX.LE.-1) THEN
10785 RTARG = RBSH(NTARG)
10787 RPROJ = RASH(NTARG)
10794 *$ CREATE DT_DIAGR.FOR
10797 *===diagr==============================================================*
10799 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10802 ************************************************************************
10803 * Based on the original version by Shmakov et al. *
10804 * This version dated 21.04.95 is revised by S. Roesler *
10805 ************************************************************************
10807 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10809 PARAMETER ( LINP = 10 ,
10812 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10813 PARAMETER (TWOPI = 6.283185307179586454D+00,
10815 & GEV2MB = 0.38938D0,
10816 & GEV2FM = 0.1972D0,
10817 & ALPHEM = ONE/137.0D0,
10825 PARAMETER ( MAXNCL = 260,
10827 & MAXSQU = 20*MAXVQU,
10828 & MAXINT = MAXVQU+MAXSQU)
10829 * particle properties (BAMJET index convention)
10831 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10832 & IICH(210),IIBAR(210),K1(210),K2(210)
10833 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10834 * emulsion treatment
10835 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10837 * Glauber formalism: parameters
10838 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10839 & BMAX(NCOMPX),BSTEP(NCOMPX),
10840 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10842 * Glauber formalism: cross sections
10843 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10844 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10845 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10846 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10847 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10848 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10849 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10850 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10851 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10852 & BSLOPE,NEBINI,NQBINI
10853 * VDM parameter for photon-nucleus interactions
10854 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10855 * nucleon-nucleon event-generator
10858 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10860 C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10862 C obsolete cut-off information
10863 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10864 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10866 * coordinates of nucleons
10867 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10868 * interface between Glauber formalism and DPM
10869 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10870 & INTER1(MAXINT),INTER2(MAXINT)
10871 * statistics: Glauber-formalism
10872 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10873 * n-n cross section fluctuations
10874 PARAMETER (NBINS = 1000)
10875 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10877 DIMENSION JS(MAXNCL),JT(MAXNCL),
10878 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10879 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10880 DIMENSION NWA(0:210),NWB(0:210)
10883 DATA LFIRST /.TRUE./
10885 DATA NTARGO,ICNT /0,0/
10891 IF (NCOMPO.EQ.0) THEN
10901 IF (NTARG.EQ.-1) THEN
10902 IF (NCOMPO.EQ.0) THEN
10903 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10904 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10905 & NCALL,NWAMAX,NWBMAX
10906 DO 18 I=1,MAX(NWAMAX,NWBMAX)
10907 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10908 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10909 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10919 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10921 X = SQ2/(S+SQ2-AMP2)
10922 XNU = (S+SQ2-AMP2)/(TWO*AMP)
10923 * photon projectiles: recalculate photon-nucleon amplitude
10924 IF (IJPROJ.EQ.7) THEN
10926 * VDM assumption: mass of V-meson
10927 AMV2 = DT_SAM2(SQ2,ECMNOW)
10929 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10930 * check for pointlike interaction
10931 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10933 C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10934 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10937 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10938 & +0.25D0*LOG(S/(AMV2+SQ2)))
10940 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10941 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10942 IF (MCGENE.EQ.2) THEN
10944 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10947 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10949 IF (ECMNOW.LE.3.0D0) THEN
10951 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10952 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10953 ELSEIF (ECMNOW.GT.50.0D0) THEN
10956 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10957 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10958 IF (MCGENE.EQ.2) THEN
10960 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10962 SIGSH = SIGSH/10.0D0
10964 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10966 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10967 SIGSH = SIGSH/10.0D0
10970 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10972 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10973 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10974 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10976 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10977 SIGSH = SIGSH/10.0D0
10979 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10981 RCA = GAM*SIGSH/TWOPI
10983 CA = DCMPLX(RCA,FCA)
10984 CI = DCMPLX(ONE,ZERO)
10988 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11001 IF (IJPROJ.EQ.7) THEN
11011 * nucleon configuration
11012 C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11013 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11014 C CALL DT_CONUCL(PKOO,NA,RASH,2)
11015 C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11016 IF (NIDX.LE.-1) THEN
11017 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11018 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11020 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11021 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11027 * LEPTO: pick out one struck nucleon
11028 IF (MCGENE.EQ.3) THEN
11031 IDX = INT(DT_RNDM(X)*NB)+1
11038 * cross section fluctuations
11040 IF (IFLUCT.EQ.1) THEN
11041 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11042 AFLUC = FLUIXX(IFLUK)
11047 * photon-projectile: check for supression by coherence length
11048 IF (IJPROJ.EQ.7) THEN
11049 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11054 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11055 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11056 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11057 IF (XY.LE.15.0D0) THEN
11058 C = CI-CA*AFLUC*EXP(-XY)
11062 IF (DT_RNDM(XY).GE.P) THEN
11064 IF (IJPROJ.EQ.7) THEN
11065 JNT0(KINT) = JNT0(KINT)+1
11066 IF (JNT0(KINT).GT.MAXNCL) THEN
11067 WRITE(LOUT,1001) MAXNCL
11069 & 'DIAGR: no. of requested interactions',
11070 & ' exceeds array dimensions ',I4)
11073 JS0(KINT) = JS0(KINT)+1
11074 JT0(KINT,INB) = JT0(KINT,INB)+1
11075 JI1(KINT,JNT0(KINT)) = INA
11076 JI2(KINT,JNT0(KINT)) = INB
11078 IF (JNT.GT.MAXINT) THEN
11079 WRITE(LOUT,1000) JNT, MAXINT
11081 & 'DIAGR: no. of requested interactions ('
11082 & ,I4,') exceeds array dimensions (',I4,')')
11085 JS(INA) = JS(INA)+1
11086 JT(INB) = JT(INB)+1
11096 IF (NTRY.LT.500) THEN
11099 C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11105 IF (IJPROJ.EQ.7) THEN
11106 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11108 IF (JNT0(K).EQ.0) THEN
11110 IF (K.GT.KINT) K = 1
11113 * supress Glauber-cascade by direct photon processes
11114 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11115 IF (IPNT.GT.0) THEN
11119 JT(INB) = JT0(K,INB)
11120 IF (JT(INB).GT.0) GOTO 12
11130 JT(INB) = JT0(K,INB)
11133 INTER1(I) = JI1(K,I)
11134 INTER2(I) = JI2(K,I)
11143 IF (JS(I).NE.0) INTA=INTA+1
11146 IF (JT(I).NE.0) INTB=INTB+1
11155 IF (NCOMPO.EQ.0) THEN
11157 NWA(INTA) = NWA(INTA)+1
11158 NWB(INTB) = NWB(INTB)+1
11164 *$ CREATE DT_MODB.FOR
11167 *===modb===============================================================*
11169 SUBROUTINE DT_MODB(B,NIDX)
11171 ************************************************************************
11172 * Sampling of impact parameter of collision. *
11173 * B impact parameter (output) *
11174 * NIDX index of projectile/target material (input)*
11175 * Based on the original version by Shmakov et al. *
11176 * This version dated 21.04.95 is revised by S. Roesler *
11178 * Last change 27.12.2006 by S. Roesler. *
11179 ************************************************************************
11181 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11183 PARAMETER ( LINP = 10 ,
11186 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11188 LOGICAL LEFT,LFIRST
11190 * central particle production, impact parameter biasing
11191 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11192 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11193 * Glauber formalism: parameters
11194 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11195 & BMAX(NCOMPX),BSTEP(NCOMPX),
11196 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11198 * Glauber formalism: cross sections
11199 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11200 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11201 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11202 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11203 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11204 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11205 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11206 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11207 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11208 & BSLOPE,NEBINI,NQBINI
11210 DATA LFIRST /.TRUE./
11213 IF (NIDX.LE.-1) THEN
11221 IF (ICENTR.EQ.2) THEN
11223 BB = DT_RNDM(B)*(0.3D0*RA)**2
11225 ELSEIF(RA.LT.RB)THEN
11226 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11228 ELSEIF(RA.GT.RB)THEN
11229 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11239 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11240 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11247 IF (I2-I0-2) 40,50,60
11250 IF (I1.GT.NSITEB) I1 = I0-1
11258 X0 = DBLE(I0-1)*BSTEP(NTARG)
11259 X1 = DBLE(I1-1)*BSTEP(NTARG)
11260 X2 = DBLE(I2-1)*BSTEP(NTARG)
11261 Y0 = BSITE(0,1,NTARG,I0)
11262 Y1 = BSITE(0,1,NTARG,I1)
11263 Y2 = BSITE(0,1,NTARG,I2)
11265 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11266 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11267 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11268 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11269 B = B+0.5D0*BSTEP(NTARG)
11270 IF (B.LT.ZERO) B = X1
11271 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11272 IF (ICENTR.LT.0) THEN
11275 IF (ICENTR.LE.-100) THEN
11280 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11281 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11282 & BIMIN,BIMAX,XSFRAC*100.0D0,
11283 & XSFRAC*XSPRO(1,1,NTARG)
11284 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11285 & /,15X,'---------------------------'/,/,4X,
11286 & 'average radii of proj / targ :',F10.3,' fm /',
11287 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11288 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11289 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11290 & ' cross section :',F10.3,' %',/,5X,
11291 & 'corresponding cross section :',F10.3,' mb',/)
11293 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11296 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11304 *$ CREATE DT_SHFAST.FOR
11307 *===shfast=============================================================*
11309 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11311 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11313 PARAMETER ( LINP = 10 ,
11316 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11317 & ONE=1.0D0,TWO=2.0D0)
11319 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11320 * Glauber formalism: parameters
11321 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11322 & BMAX(NCOMPX),BSTEP(NCOMPX),
11323 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11325 * properties of interacting particles
11326 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11327 * Glauber formalism: cross sections
11328 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11329 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11330 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11331 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11332 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11333 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11334 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11335 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11336 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11337 & BSLOPE,NEBINI,NQBINI
11341 IF (MODE.EQ.2) THEN
11342 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11343 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11344 1000 FORMAT(1X,8I5,E15.5)
11345 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11346 1001 FORMAT(1X,4E15.5)
11347 WRITE(47,1002) SIGSH,ROSH,GSH
11348 1002 FORMAT(1X,3E15.5)
11350 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11352 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11353 1003 FORMAT(1X,2I10,3E15.5)
11356 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11357 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11358 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11359 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11360 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11361 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11362 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11363 READ(47,1002) SIGSH,ROSH,GSH
11365 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11367 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11377 *$ CREATE DT_POILIK.FOR
11380 *===poilik=============================================================*
11382 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11384 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11387 PARAMETER ( LINP = 10 ,
11390 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11394 C CHARACTER*8 MDLNA
11395 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11396 C PARAMETER (IEETAB=10)
11397 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11399 C model switches and parameters
11401 INTEGER ISWMDL,IPAMDL
11402 DOUBLE PRECISION PARMDL
11403 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11404 C energy-interpolation table
11406 PARAMETER ( IEETA2 = 20 )
11408 DOUBLE PRECISION SIGTAB,SIGECM
11409 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11411 * VDM parameter for photon-nucleus interactions
11412 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11414 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11415 * Glauber formalism: cross sections
11416 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11417 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11418 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11419 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11420 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11421 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11422 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11423 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11424 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11425 & BSLOPE,NEBINI,NQBINI
11428 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11430 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11432 * load cross sections from interpolation table
11434 IF(ECM.LE.SIGECM(IP,1)) THEN
11437 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11439 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11445 WRITE(LOUT,'(/1X,A,2E12.3)')
11446 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11451 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11452 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11455 SIGANO = DT_SANO(ECM)
11457 * cross section dependence on photon virtuality
11460 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11461 & /(ONE+VIRT/PARMDL(30+I))**2
11463 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11473 C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11474 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11475 IF (ISHAD(1).EQ.1) THEN
11476 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11480 SIGANO = FSUP1*FSUP2*SIGANO
11481 SIGTOT = SIGTOT-SIGDIR-SIGANO
11482 SIGDIR = SIGDIR/(FSUP1*FSUP2)
11483 SIGANO = SIGANO/(FSUP1*FSUP2)
11484 SIGTOT = SIGTOT+SIGDIR+SIGANO
11486 RR = DT_RNDM(SIGTOT)
11487 IF (RR.LT.SIGDIR/SIGTOT) THEN
11489 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11490 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11495 RPNT = (SIGDIR+SIGANO)/SIGTOT
11496 C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11497 C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11498 C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11499 C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11500 IF (MODE.EQ.1) RETURN
11506 IF (ECM.GE.ECMNN(NEBINI)) THEN
11510 ELSEIF (ECM.GT.ECMNN(1)) THEN
11512 IF (ECM.LT.ECMNN(I)) THEN
11515 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11524 IF (NQBINI.GT.1) THEN
11525 IF (VIRT.GE.Q2G(NQBINI)) THEN
11529 ELSEIF (VIRT.GT.Q2G(1)) THEN
11531 IF (VIRT.LT.Q2G(I)) THEN
11534 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
11535 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11542 SGA = XSPRO(K1,J1,NTARG)+
11543 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11544 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11545 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11546 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11547 SDI = DBLE(NB)*SIGDIR
11548 SAN = DBLE(NB)*SIGANO
11551 IF (RR.LT.SDI/SGA) THEN
11553 ELSEIF ((RR.GE.SDI/SGA).AND.
11554 & (RR.LT.SPL/SGA)) THEN
11560 C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11566 *$ CREATE DT_GLBINI.FOR
11569 *===glbini=============================================================*
11571 SUBROUTINE DT_GLBINI(WHAT)
11573 ************************************************************************
11574 * Pre-initialization of profile function *
11575 * This version dated 28.11.00 is written by S. Roesler. *
11577 * Last change 27.12.2006 by S. Roesler. *
11578 ************************************************************************
11580 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11583 PARAMETER ( LINP = 10 ,
11586 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11590 * particle properties (BAMJET index convention)
11592 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11593 & IICH(210),IIBAR(210),K1(210),K2(210)
11594 * properties of interacting particles
11595 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11596 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11597 * emulsion treatment
11598 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11600 * Glauber formalism: flags and parameters for statistics
11603 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11604 * number of data sets other than protons and nuclei
11605 * at the moment = 2 (pions and kaons)
11606 PARAMETER (MAXOFF=2)
11607 DIMENSION IJPINI(5),IOFFST(25)
11608 DATA IJPINI / 13, 15, 0, 0, 0/
11609 * Glauber data-set to be used for hadron projectiles
11610 * (0=proton, 1=pion, 2=kaon)
11611 DATA (IOFFST(K),K=1,25) /
11612 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11614 * Acceptance interval for target nucleus mass
11615 PARAMETER (KBACC = 6)
11616 * flags for input different options
11617 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11618 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11619 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11621 PARAMETER (MAXMSS = 100)
11622 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11625 DATA JPEACH,JPSTEP / 18, 5 /
11627 * temporary patch until fix has been implemented in phojet:
11628 * maximum energy for pion projectile
11629 DATA ECMXPI / 100000.0D0 /
11631 *--------------------------------------------------------------------------
11632 * general initializations
11634 * steps in projectile mass number for initialization
11635 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11636 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11638 * energy range and binning
11641 IF (ELO.GT.EHI) ELO = EHI
11642 NEBIN = MAX(INT(WHAT(3)),1)
11643 IF (ELO.EQ.EHI) NEBIN = 0
11644 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11648 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11649 & +2.0D0*AAM(IJTARG)*EHI)
11652 * default arguments for Glauber-routine
11656 * initialize nuclear parameters, etc.
11660 * open Glauber-data output file
11661 IDX = INDEX(CGLB,' ')
11663 IF (IDX.GT.1) K = IDX-1
11664 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11666 *--------------------------------------------------------------------------
11667 * Glauber-initialization for proton and nuclei projectiles
11669 * initialize phojet for proton-proton interactions
11672 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11675 * record projectile masses
11677 NPROJ = MIN(IP,JPEACH)
11678 DO 10 KPROJ=1,NPROJ
11680 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11681 IASAV(NASAV) = KPROJ
11683 IF (IP.GT.JPEACH) THEN
11684 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11685 IF (NPROJ.EQ.0) THEN
11687 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11690 DO 11 IPROJ=1,NPROJ
11691 KPROJ = JPEACH+IPROJ*JPSTEP
11693 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11694 IASAV(NASAV) = KPROJ
11696 IF (KPROJ.LT.IP) THEN
11698 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11704 * record target masses
11707 IF (NCOMPO.GT.0) NTARG = NCOMPO
11708 DO 12 ITARG=1,NTARG
11710 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11711 IF (NCOMPO.GT.0) THEN
11712 IBSAV(NBSAV) = IEMUMA(ITARG)
11719 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11720 1000 FORMAT(I4,A,1P,2E13.5)
11721 NLINES = DBLE(NASAV)/18.0D0
11722 IF (NLINES.GT.0) THEN
11725 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11727 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11732 IF (I0.LE.NASAV) THEN
11734 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11736 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11739 NLINES = DBLE(NBSAV)/18.0D0
11740 IF (NLINES.GT.0) THEN
11743 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11745 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11750 IF (I0.LE.NBSAV) THEN
11752 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11754 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11758 * calculate Glauber-data for each energy and mass combination
11760 * loop over energy bins
11763 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11765 E = ELO+DBLE(IE-1)*DEBIN
11768 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11773 E = MAX(AAM(IJPROJ)+0.1D0,E)
11774 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11777 * loop over projectile and target masses
11780 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11781 & XI,Q2I,ECM,1,1,-1)
11787 *--------------------------------------------------------------------------
11788 * Glauber-initialization for pion, kaon, ... projectiles
11792 * initialize phojet for this interaction
11795 IJPROJ = IJPINI(IJ)
11799 * temporary patch until fix has been implemented in phojet:
11800 IF (ECMINI.GT.ECMXPI) THEN
11801 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11803 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11807 * calculate Glauber-data for each energy and mass combination
11809 * loop over energy bins
11811 E = ELO+DBLE(IE-1)*DEBIN
11814 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11819 E = MAX(AAM(IJPROJ)+TINY14,E)
11820 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11823 * loop over projectile and target masses
11825 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11832 *--------------------------------------------------------------------------
11833 * close output unit(s), etc.
11840 *$ CREATE DT_GLBSET.FOR
11843 *===glbset=============================================================*
11845 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11846 ************************************************************************
11847 * Interpolation of pre-initialized profile functions *
11848 * This version dated 28.11.00 is written by S. Roesler. *
11849 ************************************************************************
11851 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11854 PARAMETER ( LINP = 10 ,
11857 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11859 LOGICAL LCMS,LREAD,LFRST1,LFRST2
11861 * particle properties (BAMJET index convention)
11863 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11864 & IICH(210),IIBAR(210),K1(210),K2(210)
11865 * Glauber formalism: flags and parameters for statistics
11868 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11869 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11870 * Glauber formalism: parameters
11871 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11872 & BMAX(NCOMPX),BSTEP(NCOMPX),
11873 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11875 * Glauber formalism: cross sections
11876 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11877 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11878 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11879 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11880 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11881 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11882 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11883 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11884 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11885 & BSLOPE,NEBINI,NQBINI
11886 * number of data sets other than protons and nuclei
11887 * at the moment = 2 (pions and kaons)
11888 PARAMETER (MAXOFF=2)
11889 DIMENSION IJPINI(5),IOFFST(25)
11890 DATA IJPINI / 13, 15, 0, 0, 0/
11891 * Glauber data-set to be used for hadron projectiles
11892 * (0=proton, 1=pion, 2=kaon)
11893 DATA (IOFFST(K),K=1,25) /
11894 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11896 * Acceptance interval for target nucleus mass
11897 PARAMETER (KBACC = 6)
11898 * emulsion treatment
11899 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11902 PARAMETER (MAXSET=5000,
11904 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11905 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11906 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11909 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11911 * read data from file
11913 IF (MODE.EQ.0) THEN
11936 IDX = INDEX(CGLB,' ')
11938 IF (IDX.GT.1) K = IDX-1
11939 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11940 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11941 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
11944 * read binning information
11945 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11946 * return lower energy threshold to Fluka-interface
11949 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11951 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11953 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11955 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
11956 & 'No. of bins:',I5,/)
11957 ELO = LOG10(ABS(ELO))
11958 EHI = LOG10(ABS(EHI))
11959 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11960 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11961 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11962 IF (NABIN.LT.18) THEN
11963 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11965 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11967 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11968 IF (NABIN.GT.18) THEN
11969 NLINES = DBLE(NABIN-18)/18.0D0
11970 IF (NLINES.GT.0) THEN
11973 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11974 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11977 I0 = 18*(NLINES+1)+1
11978 IF (I0.LE.NABIN) THEN
11979 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11980 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11983 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11984 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11985 IF (NBBIN.LT.18) THEN
11986 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
11988 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
11990 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
11991 IF (NBBIN.GT.18) THEN
11992 NLINES = DBLE(NBBIN-18)/18.0D0
11993 IF (NLINES.GT.0) THEN
11996 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
11997 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12000 I0 = 18*(NLINES+1)+1
12001 IF (I0.LE.NBBIN) THEN
12002 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12003 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12006 * number of data sets to follow in the Glauber data file
12007 * this variable is used for checks of consistency of projectile
12008 * and target mass configurations given in header of Glauber data
12009 * file and the data-sets which follow in this file
12010 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12012 * read profile function data
12018 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12019 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12020 1002 FORMAT(5I10,E15.5)
12021 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12023 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12027 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12028 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12029 NLINES = INT(DBLE(ISITEB)/7.0D0)
12030 IF (NLINES.GT.0) THEN
12032 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12037 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12041 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12042 WRITE(LOUT,'(/,1X,A)')
12043 & ' projectiles other than protons and nuclei: (particle index)'
12044 IF (NAIDX.GT.0) THEN
12045 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12047 WRITE(LOUT,'(6X,A)') 'none'
12054 IF (NCOMPO.EQ.0) THEN
12057 IEMUMA(NCOMPO) = IBBIN(J)
12058 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12059 EMUFRA(NCOMPO) = 1.0D0
12064 * calculate profile function for certain set of parameters
12068 c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12070 * check for type of projectile and set index-offset to entry in
12071 * Glauber data array correspondingly
12072 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12073 IF (IOFFST(IDPROJ).EQ.-1) THEN
12074 STOP ' GLBSET: no data for this projectile !'
12075 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12076 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12081 * get energy bin and interpolation factor
12083 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12090 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12097 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12102 IE0 = (E-ELO)/DEBIN+1
12104 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12106 * get target nucleus index
12110 NBDIFF = ABS(NB-IBBIN(I))
12111 IF (NB.EQ.IBBIN(I)) THEN
12114 ELSEIF (NBDIFF.LE.NBACC) THEN
12119 IF (KB.NE.0) GOTO 21
12120 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12124 * get projectile nucleus bin and interpolation factor
12128 IF (IDXOFF.GT.0) THEN
12133 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12135 IF (NA.EQ.IABIN(I)) THEN
12139 ELSEIF (NA.LT.IABIN(I)) THEN
12145 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12149 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12153 * interpolate profile functions for interactions ka0-kb and ka1-kb
12154 * for energy E separately
12155 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12156 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12157 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12158 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12160 BPRO0(I) = BPROFL(IDX0,I)
12161 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12162 BPRO1(I) = BPROFL(IDY0,I)
12163 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12165 RADB = DT_RNCLUS(NB)
12166 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12167 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12169 * interpolate cross sections for energy E and projectile mass
12171 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12172 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12173 XS(I) = XS0+FACNA*(XS1-XS0)
12174 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12175 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12176 XE(I) = XE0+FACNA*(XE1-XE0)
12179 * interpolate between ka0 and ka1
12180 RADA = DT_RNCLUS(NA)
12181 BMX = 2.0D0*(RADA+RADB)
12182 BSTP = BMX/DBLE(ISITEB-1)
12187 * calculate values of profile functions at B
12189 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12190 IDX1 = MIN(IDX0+1,ISITEB)
12191 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12192 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12194 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12195 IDX1 = MIN(IDX0+1,ISITEB)
12196 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12197 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12199 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12202 * fill common dtglam
12209 BSITE(0,1,1,I) = BPRO(I)
12212 * fill common dtglxs
12213 XSTOT(1,1,1) = XS(1)
12214 XSELA(1,1,1) = XS(2)
12215 XSQEP(1,1,1) = XS(3)
12216 XSQET(1,1,1) = XS(4)
12217 XSQE2(1,1,1) = XS(5)
12218 XSPRO(1,1,1) = XS(6)
12219 XETOT(1,1,1) = XE(1)
12220 XEELA(1,1,1) = XE(2)
12221 XEQEP(1,1,1) = XE(3)
12222 XEQET(1,1,1) = XE(4)
12223 XEQE2(1,1,1) = XE(5)
12224 XEPRO(1,1,1) = XE(6)
12231 *$ CREATE DT_XKSAMP.FOR
12234 *===xksamp=============================================================*
12236 SUBROUTINE DT_XKSAMP(NN,ECM)
12238 ************************************************************************
12239 * Sampling of parton x-values and chain system for one interaction. *
12240 * processed by S. Roesler, 9.8.95 *
12241 ************************************************************************
12243 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12245 PARAMETER ( LINP = 10 ,
12248 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12252 * lower cuts for (valence-sea/sea-valence) chain masses
12253 * antiquark-quark (u/d-sea quark) (s-sea quark)
12254 & AMIU = 0.5D0, AMIS = 0.8D0,
12255 * quark-diquark (u/d-sea quark) (s-sea quark)
12256 & AMAU = 2.6D0, AMAS = 2.6D0,
12257 * maximum lower valence-x threshold
12259 * fraction of sea-diquarks sampled out of sea-partons
12261 C & FRCDIQ = 0.9D0,
12266 * maximum number of trials to generate x's for the required number
12267 * of sea quark pairs for a given hadron
12272 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12274 PARAMETER ( MAXNCL = 260,
12276 & MAXSQU = 20*MAXVQU,
12277 & MAXINT = MAXVQU+MAXSQU)
12279 PARAMETER (NMXHKK=200000)
12280 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12281 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12282 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12283 * particle properties (BAMJET index convention)
12285 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12286 & IICH(210),IIBAR(210),K1(210),K2(210)
12287 * interface between Glauber formalism and DPM
12288 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12289 & INTER1(MAXINT),INTER2(MAXINT)
12290 * properties of interacting particles
12291 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12292 * threshold values for x-sampling (DTUNUC 1.x)
12293 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12295 * x-values of partons (DTUNUC 1.x)
12296 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12297 & XTVQ(MAXVQU),XTVD(MAXVQU),
12298 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12299 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12300 * flavors of partons (DTUNUC 1.x)
12301 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12302 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12303 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12304 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12305 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12306 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12307 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12308 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12309 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12310 & IXPV,IXPS,IXTV,IXTS,
12311 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12312 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12313 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12314 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12315 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12316 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12317 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12318 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12319 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12320 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12321 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12322 * auxiliary common for chain system storage (DTUNUC 1.x)
12323 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12324 * flags for input different options
12325 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12326 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12327 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12328 * various options for treatment of partons (DTUNUC 1.x)
12329 * (chain recombination, Cronin,..)
12330 LOGICAL LCO2CR,LINTPT
12331 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12334 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12337 * (1) initializations
12338 *-----------------------------------------------------------------------
12341 IF (ECM.LT.4.5D0) THEN
12344 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12345 C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12346 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12355 IF (I.LE.MAXVQU) THEN
12361 * lower thresholds for x-selection
12362 * sea-quarks (default: CSEA=0.2)
12363 IF (ECM.LT.10.0D0) THEN
12365 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12366 C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12368 C XSTHR = ONE/ECM**2
12372 XSTHR = CSEA/ECM**2
12373 C XSTHR = ONE/ECM**2
12375 IF ((IP.GE.150).AND.(IT.GE.150))
12376 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12379 * (default: SSMIMA=0.14) used for sea-diquarks (?)
12380 XSSTHR = SSMIMA/ECM
12382 * valence-quarks (default: CVQ=1.0)
12384 * valence-diquarks (default: CDQ=2.0)
12387 * maximum-x for sea-quarks
12388 XVCUT = XVTHR+XDTHR
12389 IF (XVCUT.GT.XVMAX) THEN
12391 XVTHR = XVCUT/3.0D0
12392 XDTHR = XVCUT-XVTHR
12395 **sr 18.4. test: DPMJET
12396 C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12397 C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12398 C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12400 * maximum number of sea-pairs allowed kinematically
12401 C NSMAX = INT(OHALF*XXSEAM/XSTHR)
12402 RNSMAX = OHALF*XXSEAM/XSTHR
12403 IF (RNSMAX.GT.10000.0D0) THEN
12406 NSMAX = INT(OHALF*XXSEAM/XSTHR)
12408 * check kinematical limit for valence-x thresholds
12409 * (should be obsolete now)
12410 IF (XVCUT.GT.XVMAX) THEN
12411 WRITE(LOUT,1000) XVCUT,ECM
12412 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
12413 & ' thresholds not allowed (',2E9.3,')')
12414 C XVTHR = XVMAX-XDTHR
12415 C IF (XVTHR.LT.ZERO) STOP
12419 * set eta for valence-x sampling (BETREJ)
12420 * (UNON per default, UNOM used for projectile mesons only)
12421 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12427 * (2) select parton x-values of interacting projectile nucleons
12428 *-----------------------------------------------------------------------
12434 * get interacting projectile nucleon as sampled by Glauber
12435 IF (JSSH(IPP).NE.0) THEN
12441 * JIPP is the actual number of sea-pairs sampled for this nucleon
12442 JIPP = MIN(JSSH(IPP)-1,NSMAX)
12445 IF (JIPP.GT.0) THEN
12446 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12448 IF (XSTHR.GE.XSMAX) THEN
12453 *>>>get x-values of sea-quark pairs
12457 * accumulator for sea x-values
12460 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12461 IF (NSCOUN.GT.NSEA) THEN
12462 * decrease the number of interactions after NSEA trials
12468 IF (IPSQ(IXPS+1).LE.2) THEN
12469 **sr 8.4.98 (1/sqrt(x))
12470 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12471 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12472 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12475 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12476 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12478 **sr 8.4.98 (1/sqrt(x))
12479 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12480 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12481 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12486 IF (IPSAQ(IXPS+1).GE.-2) THEN
12487 **sr 8.4.98 (1/sqrt(x))
12488 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12489 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12490 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12493 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12494 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12496 **sr 8.4.98 (1/sqrt(x))
12497 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12498 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12499 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12503 XXSEA = XXSEA+XPSQI+XPSAQI
12504 * check for maximum allowed sea x-value
12505 IF (XXSEA.GE.XXSEAM) THEN
12509 * accept this sea-quark pair
12512 XPSAQ(IXPS) = XPSAQI
12514 ZUOSP(IXPS) = .TRUE.
12518 *>>>get x-values of valence partons
12520 IF (XVTHR.GT.0.05D0) THEN
12521 XVHI = ONE-XXSEA-XDTHR
12522 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12525 XPVQI = DT_DBETAR(OHALF,UNOPRV)
12526 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12530 XPVDI = ONE-XPVQI-XXSEA
12531 * reject according to x**1.5
12532 XDTMP = XPVDI**1.5D0
12533 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12534 * accept these valence partons
12540 ZUOVP(IXPV) = .TRUE.
12545 * (3) select parton x-values of interacting target nucleons
12546 *-----------------------------------------------------------------------
12552 * get interacting target nucleon as sampled by Glauber
12553 IF (JTSH(ITT).NE.0) THEN
12559 * JITT is the actual number of sea-pairs sampled for this nucleon
12560 JITT = MIN(JTSH(ITT)-1,NSMAX)
12563 IF (JITT.GT.0) THEN
12564 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12566 IF (XSTHR.GE.XSMAX) THEN
12571 *>>>get x-values of sea-quark pairs
12575 * accumulator for sea x-values
12578 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12579 IF (NSCOUN.GT.NSEA)THEN
12580 * decrease the number of interactions after NSEA trials
12586 IF (ITSQ(IXTS+1).LE.2) THEN
12587 **sr 8.4.98 (1/sqrt(x))
12588 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12589 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12590 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12593 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12594 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12596 **sr 8.4.98 (1/sqrt(x))
12597 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12598 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12599 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12604 IF (ITSAQ(IXTS+1).GE.-2) THEN
12605 **sr 8.4.98 (1/sqrt(x))
12606 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12607 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12608 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12611 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12612 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12614 **sr 8.4.98 (1/sqrt(x))
12615 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12616 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12617 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12621 XXSEA = XXSEA+XTSQI+XTSAQI
12622 * check for maximum allowed sea x-value
12623 IF (XXSEA.GE.XXSEAM) THEN
12627 * accept this sea-quark pair
12630 XTSAQ(IXTS) = XTSAQI
12632 ZUOST(IXTS) = .TRUE.
12636 *>>>get x-values of valence partons
12638 IF (XVTHR.GT.0.05D0) THEN
12639 XVHI = ONE-XXSEA-XDTHR
12640 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12643 XTVQI = DT_DBETAR(OHALF,UNON)
12644 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12648 XTVDI = ONE-XTVQI-XXSEA
12649 * reject according to x**1.5
12650 XDTMP = XTVDI**1.5D0
12651 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12652 * accept these valence partons
12658 ZUOVT(IXTV) = .TRUE.
12663 * (4) get valence-valence chains
12664 *-----------------------------------------------------------------------
12669 IPVAL = ITOVP(INTER1(I))
12670 ITVAL = ITOVT(INTER2(I))
12671 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12673 ZUOVP(IPVAL) = .FALSE.
12674 ZUOVT(ITVAL) = .FALSE.
12677 INTVV1(NVV) = IPVAL
12678 INTVV2(NVV) = ITVAL
12682 * (5) get sea-valence chains
12683 *-----------------------------------------------------------------------
12690 IPVAL = ITOVP(INTER1(I))
12691 ITVAL = ITOVT(INTER2(I))
12693 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12694 & ZUOVT(ITVAL)) THEN
12696 ZUOVT(ITVAL) = .FALSE.
12698 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12699 * sample sea-diquark pair
12700 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12701 IF (IREJ1.EQ.0) GOTO 260
12706 INTSV2(NSV) = ITVAL
12708 *>>>correct chain kinematics according to minimum chain masses
12709 * the actual chain masses
12710 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12711 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12712 * get lower mass cuts
12713 IF (IPSQ(J).EQ.3) THEN
12718 * q being u/d-quark
12723 * chain mass above minimum - resampling of sea-q x-value
12724 IF (AMSVQ1.GT.AMCHK1) THEN
12725 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
12726 **sr 8.4.98 (1/sqrt(x))
12727 C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
12728 C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
12729 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12731 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12733 * chain mass below minimum - reset sea-q x-value and correct
12734 * diquark-x of the same nucleon
12735 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12736 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
12737 DXPSQ = XPSQW-XPSQ(J)
12738 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12739 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12744 * chain mass below minimum - reset sea-aq x-value and correct
12745 * diquark-x of the same nucleon
12746 IF (AMSVQ2.LT.AMCHK2) THEN
12747 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12748 DXPSQ = XPSQW-XPSAQ(J)
12749 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12750 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12754 *>>>end of chain mass correction
12763 * (6) get valence-sea chains
12764 *-----------------------------------------------------------------------
12770 IPVAL = ITOVP(INTER1(I))
12771 ITVAL = ITOVT(INTER2(I))
12773 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12774 & (IFROST(J).EQ.INTER2(I))) THEN
12776 ZUOVP(IPVAL) = .FALSE.
12778 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12779 * sample sea-diquark pair
12780 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12781 IF (IREJ1.EQ.0) GOTO 290
12785 INTVS1(NVS) = IPVAL
12788 *>>>correct chain kinematics according to minimum chain masses
12789 * the actual chain masses
12790 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12791 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12792 * get lower mass cuts
12793 IF (ITSQ(J).EQ.3) THEN
12798 * q being u/d-quark
12803 * chain mass below minimum - reset sea-aq x-value and correct
12804 * diquark-x of the same nucleon
12805 IF (AMVSQ1.LT.AMCHK1) THEN
12806 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12807 DXTSQ = XTSQW-XTSAQ(J)
12808 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12809 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12814 * chain mass above minimum - resampling of sea-q x-value
12815 IF (AMVSQ2.GT.AMCHK2) THEN
12816 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
12817 **sr 8.4.98 (1/sqrt(x))
12818 C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
12819 C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
12820 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12822 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12824 * chain mass below minimum - reset sea-q x-value and correct
12825 * diquark-x of the same nucleon
12826 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12827 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
12828 DXTSQ = XTSQW-XTSQ(J)
12829 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12830 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12834 *>>>end of chain mass correction
12843 * (7) get sea-sea chains
12844 *-----------------------------------------------------------------------
12851 IPVAL = ITOVP(INTER1(I))
12852 ITVAL = ITOVT(INTER2(I))
12853 * loop over target partons not yet matched
12855 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12856 * loop over projectile partons not yet matched
12858 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12859 ZUOSP(JJ) = .FALSE.
12867 *---->chain recombination option
12868 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
12869 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12871 * sea-sea chains may recombine with valence-valence chains
12872 * only if they have the same projectile or target nucleon
12874 IF (ISKPCH(8,IVV).NE.99) THEN
12875 IXVPR = INTVV1(IVV)
12876 IXVTA = INTVV2(IVV)
12877 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12878 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12879 * recombination possible, drop old v-v and s-s chains
12883 * (a) assign new s-v chains
12884 * ~~~~~~~~~~~~~~~~~~~~~~~~~
12886 & (DT_RNDM(VALFRA).GT.FRCDIQ))
12888 * sample sea-diquark pair
12889 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12891 IF (IREJ1.EQ.0) GOTO 4202
12896 INTSV2(NSV) = IXVTA
12897 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12898 * the actual chain masses
12899 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12901 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12903 * get lower mass cuts
12904 IF (IPSQ(JJ).EQ.3) THEN
12909 * q being u/d-quark
12914 * chain mass above minimum - resampling of sea-q x-value
12915 IF (AMSVQ1.GT.AMCHK1) THEN
12917 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12918 **sr 8.4.98 (1/sqrt(x))
12920 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12921 C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
12922 C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
12925 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12927 * chain mass below minimum - reset sea-q x-value and correct
12928 * diquark-x of the same nucleon
12929 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12931 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12932 DXPSQ = XPSQW-XPSQ(JJ)
12933 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12936 & XPVD(IPVAL)-DXPSQ
12941 * chain mass below minimum - reset sea-aq x-value and correct
12942 * diquark-x of the same nucleon
12943 IF (AMSVQ2.LT.AMCHK2) THEN
12945 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
12946 DXPSQ = XPSQW-XPSAQ(JJ)
12947 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12950 & XPVD(IPVAL)-DXPSQ
12954 *>>>>>>>>>>>end of chain mass correction
12957 * (b) assign new v-s chains
12958 * ~~~~~~~~~~~~~~~~~~~~~~~~~
12960 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
12962 * sample sea-diquark pair
12963 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12965 IF (IREJ1.EQ.0) GOTO 4203
12969 INTVS1(NVS) = IXVPR
12971 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12972 * the actual chain masses
12973 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12974 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12975 * get lower mass cuts
12976 IF (ITSQ(J).EQ.3) THEN
12981 * q being u/d-quark
12986 * chain mass below minimum - reset sea-aq x-value and correct
12987 * diquark-x of the same nucleon
12988 IF (AMVSQ1.LT.AMCHK1) THEN
12990 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
12991 DXTSQ = XTSQW-XTSAQ(J)
12992 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12995 & XTVD(ITVAL)-DXTSQ
12999 IF (AMVSQ2.GT.AMCHK2) THEN
13001 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13002 **sr 8.4.98 (1/sqrt(x))
13004 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13005 C & DT_SAMSQX(XTSQTH,XTSQ(J))
13006 C & DT_SAMPEX(XTSQTH,XTSQ(J))
13009 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13011 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13013 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13014 DXTSQ = XTSQW-XTSQ(J)
13015 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13018 & XTVD(ITVAL)-DXTSQ
13022 *>>>>>>>>>end of chain mass correction
13024 * jump out of s-s chain loop
13030 *---->end of chain recombination option
13032 * sample sea-diquark pair (projectile)
13033 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13034 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13035 IF (IREJ1.EQ.0) THEN
13040 * sample sea-diquark pair (target)
13041 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13042 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13043 IF (IREJ1.EQ.0) THEN
13048 *>>>>>correct chain kinematics according to minimum chain masses
13049 * the actual chain masses
13050 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13051 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13052 * check for lower mass cuts
13053 IF ((SSMA1Q.LT.SSMIMQ).OR.
13054 & (SSMA2Q.LT.SSMIMQ)) THEN
13055 IPVAL = ITOVP(INTER1(I))
13056 ITVAL = ITOVT(INTER2(I))
13057 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13058 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13059 * maximum allowed x values for sea quarks
13060 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13062 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13064 * resampling of x values not possible - skip sea-sea chains
13065 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13066 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13067 * resampling of x for projectile sea quark pair
13071 IF (XSSTHR.GT.0.05D0) THEN
13072 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13074 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13078 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13079 IF ((XPSQI.LT.XSSTHR).OR.
13080 & (XPSQI.GT.XSPMAX)) GOTO 320
13082 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13083 IF ((XPSAQI.LT.XSSTHR).OR.
13084 & (XPSAQI.GT.XSPMAX)) GOTO 330
13086 * final test of remaining x for projectile diquark
13087 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13088 & +XPSQ(JJ)+XPSAQ(JJ)
13089 IF (XPVDCO.LE.XDTHR) THEN
13091 C IF (ICOUS.LT.5) GOTO 310
13092 IF (ICOUS.LT.0.5D0) GOTO 310
13095 * resampling of x for target sea quark pair
13099 IF (XSSTHR.GT.0.05D0) THEN
13100 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13102 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13106 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13107 IF ((XTSQI.LT.XSSTHR).OR.
13108 & (XTSQI.GT.XSTMAX)) GOTO 360
13110 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13111 IF ((XTSAQI.LT.XSSTHR).OR.
13112 & (XTSAQI.GT.XSTMAX)) GOTO 370
13114 * final test of remaining x for target diquark
13115 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13116 & +XTSQ(J)+XTSAQ(J)
13117 IF (XTVDCO.LT.XDTHR) THEN
13118 IF (ICOUS.LT.5) GOTO 350
13121 XPVD(IPVAL) = XPVDCO
13122 XTVD(ITVAL) = XTVDCO
13127 *>>>>>end of chain mass correction
13130 * come here to discard s-s interaction
13131 * resampling of x values not allowed or unsuccessful
13138 * consider next s-s interaction
13148 * correct x-values of valence quarks for non-matching sea quarks
13151 IPVAL = ITOVP(IFROSP(I))
13152 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13160 ITVAL = ITOVT(IFROST(I))
13161 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13168 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13171 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13177 *$ CREATE DT_SAMSDQ.FOR
13180 *===samsdq=============================================================*
13182 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13184 ************************************************************************
13185 * SAMpling of Sea-DiQuarks *
13186 * ECM cm-energy of the nucleon-nucleon system *
13187 * IDX1,2 indices of x-values of the participating *
13188 * partons (IDX2 is always the sea-q-pair to be *
13189 * changed to sea-qq-pair) *
13190 * MODE = 1 valence-q - sea-diq *
13191 * = 2 sea-diq - valence-q *
13192 * = 3 sea-q - sea-diq *
13193 * = 4 sea-diq - sea-q *
13194 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13195 * This version dated 17.10.95 is written by S. Roesler *
13196 ************************************************************************
13198 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13201 PARAMETER (ZERO=0.0D0)
13203 * threshold values for x-sampling (DTUNUC 1.x)
13204 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13206 * various options for treatment of partons (DTUNUC 1.x)
13207 * (chain recombination, Cronin,..)
13208 LOGICAL LCO2CR,LINTPT
13209 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13211 PARAMETER ( MAXNCL = 260,
13213 & MAXSQU = 20*MAXVQU,
13214 & MAXINT = MAXVQU+MAXSQU)
13215 * x-values of partons (DTUNUC 1.x)
13216 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13217 & XTVQ(MAXVQU),XTVD(MAXVQU),
13218 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13219 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13220 * flavors of partons (DTUNUC 1.x)
13221 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13222 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13223 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13224 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13225 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13226 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13227 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13228 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13229 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13230 & IXPV,IXPS,IXTV,IXTS,
13231 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13232 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13233 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13234 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13235 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13236 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13237 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13238 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13239 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13240 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13241 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13242 * auxiliary common for chain system storage (DTUNUC 1.x)
13243 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13246 * threshold-x for valence diquarks
13249 GOTO (1,2,3,4) MODE
13251 *---------------------------------------------------------------------
13252 * proj. valence partons - targ. sea partons
13253 * get x-values and flavors for target sea-diquark pair
13259 * index of corr. val-diquark-x in target nucleon
13260 IDXVT = ITOVT(IFROST(IDXST))
13261 * available x above diquark thresholds for valence- and sea-diquarks
13262 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13264 IF (XXD.GE.ZERO) THEN
13265 * x-values for the three diquarks of the target nucleon
13269 SR123 = RR1+RR2+RR3
13270 XXTV = XDTHR+RR1*XXD/SR123
13271 XXTSQ = XDTHR+RR2*XXD/SR123
13272 XXTSAQ = XDTHR+RR3*XXD/SR123
13275 XXTSQ = XTSQ(IDXST)
13276 XXTSAQ = XTSAQ(IDXST)
13278 * flavor of the second quarks in the sea-diquark pair
13279 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13280 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13281 * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13282 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13283 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13284 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13286 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13289 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13290 * at least one strange quark
13291 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13294 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13298 * accept the new sea-diquark
13300 XTSQ(IDXST) = XXTSQ
13301 XTSAQ(IDXST) = XXTSAQ
13303 INTVD1(NVD) = IDXVP
13304 INTVD2(NVD) = IDXST
13308 *---------------------------------------------------------------------
13309 * proj. sea partons - targ. valence partons
13310 * get x-values and flavors for projectile sea-diquark pair
13316 * index of corr. val-diquark-x in projectile nucleon
13317 IDXVP = ITOVP(IFROSP(IDXSP))
13318 * available x above diquark thresholds for valence- and sea-diquarks
13319 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13321 IF (XXD.GE.ZERO) THEN
13322 * x-values for the three diquarks of the projectile nucleon
13326 SR123 = RR1+RR2+RR3
13327 XXPV = XDTHR+RR1*XXD/SR123
13328 XXPSQ = XDTHR+RR2*XXD/SR123
13329 XXPSAQ = XDTHR+RR3*XXD/SR123
13332 XXPSQ = XPSQ(IDXSP)
13333 XXPSAQ = XPSAQ(IDXSP)
13335 * flavor of the second quarks in the sea-diquark pair
13336 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13337 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13338 * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13339 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13340 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13341 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13343 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13346 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13347 * at least one strange quark
13348 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13351 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13355 * accept the new sea-diquark
13357 XPSQ(IDXSP) = XXPSQ
13358 XPSAQ(IDXSP) = XXPSAQ
13360 INTDV1(NDV) = IDXSP
13361 INTDV2(NDV) = IDXVT
13365 *---------------------------------------------------------------------
13366 * proj. sea partons - targ. sea partons
13367 * get x-values and flavors for target sea-diquark pair
13373 * index of corr. val-diquark-x in target nucleon
13374 IDXVT = ITOVT(IFROST(IDXST))
13375 * available x above diquark thresholds for valence- and sea-diquarks
13376 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13378 IF (XXD.GE.ZERO) THEN
13379 * x-values for the three diquarks of the target nucleon
13383 SR123 = RR1+RR2+RR3
13384 XXTV = XDTHR+RR1*XXD/SR123
13385 XXTSQ = XDTHR+RR2*XXD/SR123
13386 XXTSAQ = XDTHR+RR3*XXD/SR123
13389 XXTSQ = XTSQ(IDXST)
13390 XXTSAQ = XTSAQ(IDXST)
13392 * flavor of the second quarks in the sea-diquark pair
13393 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13394 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13395 * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13396 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
13397 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13398 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13400 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13403 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13404 * at least one strange quark
13405 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13408 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13412 * accept the new sea-diquark
13414 XTSQ(IDXST) = XXTSQ
13415 XTSAQ(IDXST) = XXTSAQ
13417 INTSD1(NSD) = IDXSP
13418 INTSD2(NSD) = IDXST
13422 *---------------------------------------------------------------------
13423 * proj. sea partons - targ. sea partons
13424 * get x-values and flavors for projectile sea-diquark pair
13430 * index of corr. val-diquark-x in projectile nucleon
13431 IDXVP = ITOVP(IFROSP(IDXSP))
13432 * available x above diquark thresholds for valence- and sea-diquarks
13433 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13435 IF (XXD.GE.ZERO) THEN
13436 * x-values for the three diquarks of the projectile nucleon
13440 SR123 = RR1+RR2+RR3
13441 XXPV = XDTHR+RR1*XXD/SR123
13442 XXPSQ = XDTHR+RR2*XXD/SR123
13443 XXPSAQ = XDTHR+RR3*XXD/SR123
13446 XXPSQ = XPSQ(IDXSP)
13447 XXPSAQ = XPSAQ(IDXSP)
13449 * flavor of the second quarks in the sea-diquark pair
13450 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13451 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13452 * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13453 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
13454 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
13455 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13457 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13460 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13461 * at least one strange quark
13462 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13465 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13469 * accept the new sea-diquark
13471 XPSQ(IDXSP) = XXPSQ
13472 XPSAQ(IDXSP) = XXPSAQ
13474 INTDS1(NDS) = IDXSP
13475 INTDS2(NDS) = IDXST
13480 *$ CREATE DT_DIFEVT.FOR
13483 *===difevt=============================================================*
13485 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13486 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13488 ************************************************************************
13489 * Interface to treatment of diffractive interactions. *
13490 * (input) IFP1/2 PDG-indizes of projectile partons *
13491 * (baryon: IFP2 - adiquark) *
13492 * PP(4) projectile 4-momentum *
13493 * IFT1/2 PDG-indizes of target partons *
13494 * (baryon: IFT1 - adiquark) *
13495 * PT(4) target 4-momentum *
13496 * (output) JDIFF = 0 no diffraction *
13497 * = 1/-1 LMSD/LMDD *
13498 * = 2/-2 HMSD/HMDD *
13499 * NCSY counter for two-chain systems *
13500 * dumped to DTEVT1 *
13501 * This version dated 14.02.95 is written by S. Roesler *
13502 ************************************************************************
13504 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13506 PARAMETER ( LINP = 10 ,
13509 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13513 PARAMETER (NMXHKK=200000)
13514 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13515 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13516 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13517 * extended event history
13518 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13519 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13521 * flags for diffractive interactions (DTUNUC 1.x)
13522 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13524 DIMENSION PP(4),PT(4)
13527 DATA LFIRST /.TRUE./
13534 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13535 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13536 * identities of projectile hadron / target nucleon
13537 KPROJ = IDT_ICIHAD(IDHKK(MOP))
13538 KTARG = IDT_ICIHAD(IDHKK(MOT))
13540 * single diffractive xsections
13541 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13542 * double diffractive xsections
13543 **!! no double diff yet
13544 C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13548 * total inelastic xsection
13549 C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13551 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13552 SIGIN = MAX(SIGTO-SIGEL,ZERO)
13554 * fraction of diffractive processes
13555 FRADIF = (SDTOT+DDTOT)/SIGIN
13558 WRITE(LOUT,1000) XM,SDTOT,SIGIN
13559 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13560 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13565 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13566 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13567 * diffractive interaction requested by x-section or by user
13568 FRASD = SDTOT/(SDTOT+DDTOT)
13569 FRASDH = SDHM/SDTOT
13570 **sr needs to be specified!!
13571 C FRADDH = DDHM/DDTOT
13574 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13575 * single diffraction
13577 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13580 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13581 & ISINGD.NE.3) THEN
13588 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13589 & ISINGD.NE.3) THEN
13595 * double diffraction
13597 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13605 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13606 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13607 IF (IREJ1.EQ.0) THEN
13609 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13623 *$ CREATE DT_DIFFKI.FOR
13626 *===difkin=============================================================*
13628 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13629 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13631 ************************************************************************
13632 * Kinematics of diffractive nucleon-nucleon interaction. *
13633 * IFP1/2 PDG-indizes of projectile partons *
13634 * (baryon: IFP2 - adiquark) *
13635 * PP(4) projectile 4-momentum *
13636 * IFT1/2 PDG-indizes of target partons *
13637 * (baryon: IFT1 - adiquark) *
13638 * PT(4) target 4-momentum *
13639 * KP = 0 projectile quasi-elastically scattered *
13640 * = 1 excited to low-mass diff. state *
13641 * = 2 excited to high-mass diff. state *
13642 * KT = 0 target quasi-elastically scattered *
13643 * = 1 excited to low-mass diff. state *
13644 * = 2 excited to high-mass diff. state *
13645 * This version dated 12.02.95 is written by S. Roesler *
13646 ************************************************************************
13648 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13650 PARAMETER ( LINP = 10 ,
13653 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13657 * particle properties (BAMJET index convention)
13659 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13660 & IICH(210),IIBAR(210),K1(210),K2(210)
13661 * flags for input different options
13662 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13663 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13664 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13665 * rejection counter
13666 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13667 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13668 & IREXCI(3),IRDIFF(2),IRINC
13669 * kinematics of diffractive interactions (DTUNUC 1.x)
13670 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13672 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13673 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13675 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13676 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13678 DATA LSTART /.TRUE./
13682 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
13688 * initialize common /DTDIKI/
13690 * store momenta of initial incoming particles for emc-check
13692 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13693 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13696 * masses of initial particles
13697 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13698 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13699 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13702 * check quark-input (used to adjust coherence cond. for M-selection)
13704 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13706 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13708 * parameter for Lorentz-transformation into nucleon-nucleon cms
13710 PITOT(K) = PP(K)+PT(K)
13712 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13713 IF (XMTOT2.LE.ZERO) THEN
13714 WRITE(LOUT,1000) XMTOT2
13715 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
13716 & 'XMTOT2 = ',E12.3)
13719 XMTOT = SQRT(XMTOT2)
13721 BGTOT(K) = PITOT(K)/XMTOT
13723 * transformation of nucleons into cms
13724 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13725 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13726 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13727 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13730 C SID = SQRT((ONE-COD)*(ONE+COD))
13731 PPT = SQRT(PP1(1)**2+PP1(2)**2)
13735 IF(PPTOT*SID.GT.TINY10) THEN
13736 COF = PP1(1)/(SID*PPTOT)
13737 SIF = PP1(2)/(SID*PPTOT)
13738 ANORF = SQRT(COF*COF+SIF*SIF)
13742 * check consistency
13744 DEV1(K) = ABS(PP1(K)+PT1(K))
13746 DEV1(4) = ABS(DEV1(4)-XMTOT)
13747 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13748 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
13749 WRITE(LOUT,1001) DEV1
13750 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
13755 * select x-fractions in high-mass diff. interactions
13756 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13758 * select diffractive masses
13761 XMPF = DT_XMLMD(XMTOT)
13762 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13763 IF (IREJ1.GT.0) GOTO 9999
13764 ELSEIF (KP.EQ.2) THEN
13765 XMPF = DT_XMHMD(XMTOT,IBP,1)
13771 XMTF = DT_XMLMD(XMTOT)
13772 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13773 IF (IREJ1.GT.0) GOTO 9999
13774 ELSEIF (KT.EQ.2) THEN
13775 XMTF = DT_XMHMD(XMTOT,IBT,2)
13780 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13783 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13784 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13786 * select momentum transfer (all t-values used here are <0)
13787 * minimum absolute value to produce diffractive masses
13788 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13789 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13790 IF (IREJ1.GT.0) GOTO 9999
13792 * longitudinal momentum of excited/elastically scattered projectile
13793 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13794 * total transverse momentum due to t-selection
13795 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13796 IF (PPBLT2.LT.ZERO) THEN
13797 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13798 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
13799 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13802 CALL DT_DSFECF(SINPHI,COSPHI)
13803 PPBLT = SQRT(PPBLT2)
13804 PPBLOB(1) = COSPHI*PPBLT
13805 PPBLOB(2) = SINPHI*PPBLT
13807 * rotate excited/elastically scattered projectile into n-n cms.
13808 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13814 * 4-momentum of excited/elastically scattered target and of exchanged
13817 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13818 PPOM1(K) = PP1(K)-PPBLOB(K)
13820 PTBLOB(4) = XMTOT-PPBLOB(4)
13822 * Lorentz-transformation back into system of initial diff. collision
13823 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13824 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13825 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13826 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13827 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13828 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13829 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13830 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13831 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13833 * store 4-momentum of elastically scattered particle (in single diff.
13839 ELSEIF (KT.EQ.0) THEN
13845 * check consistency of kinematical treatment so far
13847 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13848 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13849 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13850 IF (IREJ1.NE.0) GOTO 9999
13853 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13854 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13856 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13857 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13858 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13859 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
13860 WRITE(LOUT,1003) DEV1,DEV2
13861 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
13866 * kinematical treatment for low-mass diffraction
13867 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13868 IF (IREJ1.NE.0) GOTO 9999
13870 * dump diffractive chains into DTEVT1
13871 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13872 IF (IREJ1.NE.0) GOTO 9999
13877 IRDIFF(1) = IRDIFF(1)+1
13882 *$ CREATE DT_XMHMD.FOR
13885 *===xmhmd==============================================================*
13887 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13889 ************************************************************************
13890 * Diffractive mass in high mass single/double diffractive events. *
13891 * This version dated 11.02.95 is written by S. Roesler *
13892 ************************************************************************
13894 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13896 PARAMETER ( LINP = 10 ,
13899 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13901 * kinematics of diffractive interactions (DTUNUC 1.x)
13902 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13904 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13905 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13907 C DATA XCOLOW /0.05D0/
13908 DATA XCOLOW /0.15D0/
13912 IF (MODE.EQ.2) XH = XTH(2)
13914 * minimum Pomeron-x for high-mass diffraction
13915 * (adjusted to get a smooth transition between HM and LM component)
13917 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13918 IF (ECM.LE.300.0D0) THEN
13919 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13920 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13922 * maximum Pomeron-x for high-mass diffraction
13923 * (coherence condition, adjusted to fit to experimental data)
13925 * baryon-diffraction
13926 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13928 * meson-diffraction
13929 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13932 IF (XDIMIN.GE.XDIMAX) THEN
13933 XDIMIN = OHALF*XDIMAX
13939 IF (KLOOP.GT.20) RETURN
13940 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
13941 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13942 * corr. diffr. mass
13943 DT_XMHMD = ECM*SQRT(XDIFF)
13944 IF (DT_XMHMD.LT.2.5D0) GOTO 1
13949 *$ CREATE DT_XMLMD.FOR
13952 *===xmlmd==============================================================*
13954 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13956 ************************************************************************
13957 * Diffractive mass in high mass single/double diffractive events. *
13958 * This version dated 11.02.95 is written by S. Roesler *
13959 ************************************************************************
13961 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13963 PARAMETER ( LINP = 10 ,
13967 * minimum Pomeron-x for low-mass diffraction
13970 * maximum Pomeron-x for low-mass diffraction
13971 * (adjusted to get a smooth transition between HM and LM component)
13974 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13975 R = DT_RNDM(AMO)*SAM
13976 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13977 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13979 * selection of diffractive mass
13980 * (adjusted to get a smooth transition between HM and LM component)
13982 IF (ECM.LE.50.0D0) THEN
13983 DT_XMLMD = AMO*(AMU/AMO)**R
13986 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
13987 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
13993 *$ CREATE DT_TDIFF.FOR
13996 *===tdiff==============================================================*
13998 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14000 ************************************************************************
14001 * t-selection for single/double diffractive interactions. *
14003 * TMIN minimum momentum transfer to produce diff. masses *
14004 * XM1/XM2 diffractively produced masses *
14005 * (for single diffraction XM2 is obsolete) *
14006 * K1/K2= 0 not excited *
14007 * = 1 low-mass excitation *
14008 * = 2 high-mass excitation *
14009 * This version dated 11.02.95 is written by S. Roesler *
14010 ************************************************************************
14012 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14014 PARAMETER ( LINP = 10 ,
14017 PARAMETER (ZERO=0.0D0)
14019 PARAMETER ( BTP0 = 3.7D0,
14020 & ALPHAP = 0.24D0 )
14033 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14034 * slope for single diffraction
14035 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14037 * slope for double diffraction
14038 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14043 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14045 T = -LOG(1.0D0-Y)/SLOPE
14046 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14052 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14053 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14054 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14055 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14060 *$ CREATE DT_XVALHM.FOR
14063 *===xvalhm=============================================================*
14065 SUBROUTINE DT_XVALHM(KP,KT)
14067 ************************************************************************
14068 * Sampling of parton x-values in high-mass diffractive interactions. *
14069 * This version dated 12.02.95 is written by S. Roesler *
14070 ************************************************************************
14072 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14074 PARAMETER ( LINP = 10 ,
14077 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14079 * kinematics of diffractive interactions (DTUNUC 1.x)
14080 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14082 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14083 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14084 * various options for treatment of partons (DTUNUC 1.x)
14085 * (chain recombination, Cronin,..)
14086 LOGICAL LCO2CR,LINTPT
14087 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14090 DATA UNON,XVQTHR /2.0D0,0.8D0/
14093 * x-fractions of projectile valence partons
14095 XPH(1) = DT_DBETAR(OHALF,UNON)
14096 IF (XPH(1).GE.XVQTHR) GOTO 1
14097 XPH(2) = ONE-XPH(1)
14098 * x-fractions of Pomeron q-aq-pair
14101 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14102 XPPO(2) = ONE-XPPO(1)
14103 * flavors of Pomeron q-aq-pair
14104 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14107 IF (DT_RNDM(UNON).GT.OHALF) THEN
14114 * x-fractions of projectile target partons
14116 XTH(1) = DT_DBETAR(OHALF,UNON)
14117 IF (XTH(1).GE.XVQTHR) GOTO 2
14118 XTH(2) = ONE-XTH(1)
14119 * x-fractions of Pomeron q-aq-pair
14122 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14123 XTPO(2) = ONE-XTPO(1)
14124 * flavors of Pomeron q-aq-pair
14125 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14128 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14137 *$ CREATE DT_LM2RES.FOR
14140 *===lm2res=============================================================*
14142 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14144 ************************************************************************
14145 * Check low-mass diffractive excitation for resonance mass. *
14146 * (input) IF1/2 PDG-indizes of valence partons *
14147 * (in/out) XM diffractive mass requested/corrected *
14148 * (output) IDR/IDXR id./BAMJET-index of resonance *
14149 * This version dated 12.02.95 is written by S. Roesler *
14150 ************************************************************************
14152 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14154 PARAMETER ( LINP = 10 ,
14157 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14159 * kinematics of diffractive interactions (DTUNUC 1.x)
14160 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14162 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14163 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14170 * BAMJET indices of partons
14171 IF1A = IDT_IPDG2B(IF1,1,2)
14172 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14173 IF2A = IDT_IPDG2B(IF2,1,2)
14174 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14176 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14178 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14180 * check for resonance mass
14181 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14182 IF (IREJ1.NE.0) GOTO 9999
14192 *$ CREATE DT_LMKINE.FOR
14195 *===lmkine=============================================================*
14197 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14199 ************************************************************************
14200 * Kinematical treatment of low-mass excitations. *
14201 * This version dated 12.02.95 is written by S. Roesler *
14202 ************************************************************************
14204 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14206 PARAMETER ( LINP = 10 ,
14209 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14211 * flags for input different options
14212 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14213 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14214 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14215 * kinematics of diffractive interactions (DTUNUC 1.x)
14216 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14218 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14219 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14221 DIMENSION P1(4),P2(4)
14226 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14228 FAC1 = OHALF*(POE+ONE)
14229 FAC2 = -OHALF*(POE-ONE)
14231 PPLM1(K) = FAC1*PPF(K)
14232 PPLM2(K) = FAC2*PPF(K)
14234 PPLM1(4) = FAC1*PABS
14235 PPLM2(4) = -FAC2*PABS
14236 IF (IMSHL.EQ.1) THEN
14239 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14240 IF (IREJ1.NE.0) GOTO 9999
14249 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14251 FAC1 = OHALF*(POE+ONE)
14252 FAC2 = -OHALF*(POE-ONE)
14254 PTLM2(K) = FAC1*PTF(K)
14255 PTLM1(K) = FAC2*PTF(K)
14257 PTLM2(4) = FAC1*PABS
14258 PTLM1(4) = -FAC2*PABS
14259 IF (IMSHL.EQ.1) THEN
14262 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14263 IF (IREJ1.NE.0) GOTO 9999
14274 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14279 *$ CREATE DT_DIFINI.FOR
14282 *===difini=============================================================*
14284 SUBROUTINE DT_DIFINI
14286 ************************************************************************
14287 * Initialization of common /DTDIKI/ *
14288 * This version dated 12.02.95 is written by S. Roesler *
14289 ************************************************************************
14291 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14293 PARAMETER ( LINP = 10 ,
14296 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14298 * kinematics of diffractive interactions (DTUNUC 1.x)
14299 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14301 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14302 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14330 *$ CREATE DT_DIFPUT.FOR
14333 *===difput=============================================================*
14335 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14338 ************************************************************************
14339 * Dump diffractive chains into DTEVT1 *
14340 * This version dated 12.02.95 is written by S. Roesler *
14341 ************************************************************************
14343 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14345 PARAMETER ( LINP = 10 ,
14348 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14352 * kinematics of diffractive interactions (DTUNUC 1.x)
14353 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14355 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14356 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14358 PARAMETER (NMXHKK=200000)
14359 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14360 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14361 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14362 * extended event history
14363 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14364 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14366 * rejection counter
14367 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14368 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14369 & IREXCI(3),IRDIFF(2),IRINC
14371 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14372 & P1(4),P2(4),P3(4),P4(4)
14378 PCH(K) = PPLM1(K)+PPLM2(K)
14382 IF (DT_RNDM(PT).GT.OHALF) THEN
14386 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14388 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14390 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14392 ELSEIF (KP.EQ.2) THEN
14394 PP1(K) = XPH(1)*PP(K)
14395 PP2(K) = XPH(2)*PP(K)
14396 PT1(K) = -XPPO(1)*PPOM(K)
14397 PT2(K) = -XPPO(2)*PPOM(K)
14399 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14403 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14404 IF (IREJ1.NE.0) GOTO 9999
14405 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14406 IF (IREJ1.NE.0) GOTO 9999
14413 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14415 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14417 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14419 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14422 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14423 IF (IREJ1.NE.0) GOTO 9999
14424 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14425 IF (IREJ1.NE.0) GOTO 9999
14432 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14434 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14436 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14438 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14443 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14449 PCH(K) = PTLM1(K)+PTLM2(K)
14453 IF (DT_RNDM(PT).GT.OHALF) THEN
14457 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14459 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14461 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14463 ELSEIF (KT.EQ.2) THEN
14465 PP1(K) = XTPO(1)*PPOM(K)
14466 PP2(K) = XTPO(2)*PPOM(K)
14467 PT1(K) = XTH(2)*PT(K)
14468 PT2(K) = XTH(1)*PT(K)
14470 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14474 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14475 IF (IREJ1.NE.0) GOTO 9999
14476 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14477 IF (IREJ1.NE.0) GOTO 9999
14484 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14486 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14488 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14490 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14493 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14494 IF (IREJ1.NE.0) GOTO 9999
14495 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14496 IF (IREJ1.NE.0) GOTO 9999
14503 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14505 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14507 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14509 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14514 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14521 IRDIFF(2) = IRDIFF(2)+1
14526 *$ CREATE DT_EVTFRG.FOR
14529 *===evtfrg=============================================================*
14531 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14533 ************************************************************************
14534 * Hadronization of chains in DTEVT1. *
14537 * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
14538 * = 2 hadronization of DTUNUC-chains (id=88xxx) *
14539 * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
14540 * hadronized with one PYEXEC call *
14541 * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14542 * with one PYEXEC call *
14544 * NPYMEM number of entries in JETSET-common after hadronization *
14545 * IREJ rejection flag *
14547 * This version dated 17.09.00 is written by S. Roesler *
14548 ************************************************************************
14550 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14552 PARAMETER ( LINP = 10 ,
14555 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14556 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14560 PARAMETER (MXJOIN=200)
14563 PARAMETER (NMXHKK=200000)
14564 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14565 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14566 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14567 * extended event history
14568 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14569 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14571 * flags for input different options
14572 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14573 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14574 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14576 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14577 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14579 * flags for diffractive interactions (DTUNUC 1.x)
14580 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14581 * nucleon-nucleon event-generator
14584 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14586 C model switches and parameters
14588 INTEGER ISWMDL,IPAMDL
14589 DOUBLE PRECISION PARMDL
14590 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14592 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14593 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
14594 PARAMETER (MAXLND=4000)
14595 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14597 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14601 IF (MODE.NE.1) ISTSTG = 8
14610 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14611 DO 10 I=NPOINT(3),NEND
14612 * sr 14.02.00: seems to be not necessary anymore, commented
14613 C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14614 C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14616 * pick up chains from dtevt1
14617 IDCHK = IDHKK(I)/10000
14618 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14619 IF (IDCHK.EQ.7) THEN
14620 IPJE = IDHKK(I)-IDCHK*10000
14621 IF (IPJE.NE.IFRG) THEN
14623 IF (IFRG.GT.NFRG) GOTO 16
14628 IF (IFRG.GT.NFRG) THEN
14633 * statistics counter
14634 c IF (IDCH(I).LE.8)
14635 c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14636 c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14637 * special treatment for small chains already corrected to hadrons
14638 IF (IDRES(I).NE.0) THEN
14639 IF (IDRES(I).EQ.11) THEN
14642 ID = IDT_IPDGHA(IDXRES(I))
14645 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14646 & PHKK(4,I),INIEMC,IDUM,IDUM)
14650 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14651 P(IP,1) = PHKK(1,I)
14652 P(IP,2) = PHKK(2,I)
14653 P(IP,3) = PHKK(3,I)
14654 P(IP,4) = PHKK(4,I)
14655 P(IP,5) = PHKK(5,I)
14661 IHIST(2,I) = 10000*IPJE+IP
14662 IF (IHIST(1,I).LE.-100) THEN
14664 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14671 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14673 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14674 & PHKK(4,KK),INIEMC,IDUM,IDUM)
14675 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14679 IF (ID.EQ.0) ID = 21
14680 c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14681 c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14682 c AMRQ = PYMASS(ID)
14683 c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14684 c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14685 c & (ABS(IDIFF).EQ.0)) THEN
14686 cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14687 c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14688 c PHKK(4,KK) = PHKK(4,KK)+DELTA
14689 c PTOT1 = PTOT-DELTA
14690 c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14691 c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14692 c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14693 c PHKK(5,KK) = AMRQ
14696 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14697 P(IP,1) = PHKK(1,KK)
14698 P(IP,2) = PHKK(2,KK)
14699 P(IP,3) = PHKK(3,KK)
14700 P(IP,4) = PHKK(4,KK)
14701 P(IP,5) = PHKK(5,KK)
14707 IHIST(2,KK) = 10000*IPJE+IP
14708 IF (IHIST(1,KK).LE.-100) THEN
14710 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14714 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14719 * join the two-parton system
14720 CALL PYJOIN(IJ,IJOIN)
14730 * final state parton shower
14732 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14733 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14735 IF (ISJOIN(K1).EQ.0) GOTO 130
14737 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14739 IH1 = IHIST(2,I)/10000
14740 IF (IH1.NE.NPJE) GOTO 130
14741 IH1 = IHIST(2,I)-IH1*10000
14743 IF (ISJOIN(K2).EQ.0) GOTO 135
14745 IH2 = IHIST(2,II)/10000
14746 IF (IH2.NE.NPJE) GOTO 135
14747 IH2 = IHIST(2,II)-IH2*10000
14748 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14749 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14750 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14751 RQLUN = MIN(PT1,PT2)
14752 CALL PYSHOW(IH1,IH2,RQLUN)
14764 CALL DT_INITJS(MODE)
14769 IF (MSTU(24).NE.0) THEN
14770 WRITE(LOUT,*) ' JETSET-reject at event',
14771 & NEVHKK,MSTU(24),KMODE
14772 C CALL DT_EVTOUT(4)
14779 * number of entries in LUJETS
14791 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14793 * pick up mother resonance if possible and put it together with
14794 * their decay-products into the common
14796 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14797 KFMOR = K(IDXMOR,2)
14798 ISMOR = K(IDXMOR,1)
14803 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14804 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14806 MO = IHISMO(PYK(IDXMOR,15))
14811 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14814 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14815 IF (PYK(JDAUG,7).EQ.1) THEN
14821 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14827 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14833 * there was no mother resonance
14834 MO = IHISMO(PYK(II,15))
14840 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14846 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14853 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14854 C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14857 * global energy-momentum & flavor conservation check
14858 **sr 16.5. this check is skipped in case of phojet-treatment
14860 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14862 * update statistics-counter for diffraction
14863 c IF (IFLAGD.NE.0) THEN
14864 c ICDIFF(1) = ICDIFF(1)+1
14865 c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14866 c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14867 c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14868 c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14880 *$ CREATE DT_DECAYS.FOR
14883 *===decay==============================================================*
14885 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14887 ************************************************************************
14888 * Resonance-decay. *
14889 * This subroutine replaces DDECAY/DECHKK. *
14890 * PIN(4) 4-momentum of resonance (input) *
14891 * IDXIN BAMJET-index of resonance (input) *
14892 * POUT(20,4) 4-momenta of decay-products (output) *
14893 * IDXOUT(20) BAMJET-indices of decay-products (output) *
14894 * NSEC number of secondaries (output) *
14895 * Adopted from the original version DECHKK. *
14896 * This version dated 09.01.95 is written by S. Roesler *
14897 ************************************************************************
14899 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14901 PARAMETER ( LINP = 10 ,
14904 PARAMETER (TINY17=1.0D-17)
14906 * HADRIN: decay channel information
14907 PARAMETER (IDMAX9=602)
14909 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14910 * particle properties (BAMJET index convention)
14912 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14913 & IICH(210),IIBAR(210),K1(210),K2(210)
14914 * flags for input different options
14915 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14916 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14917 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14919 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14920 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14921 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14923 * ISTAB = 1 strong and weak decays
14924 * = 2 strong decays only
14925 * = 3 strong decays, weak decays for charmed particles and tau
14931 * put initial resonance to stack
14933 IDXSTK(NSTK) = IDXIN
14935 PI(NSTK,I) = PIN(I)
14938 * store initial configuration for energy-momentum cons. check
14939 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14940 & PI(NSTK,4),1,IDUM,IDUM)
14943 * get particle from stack
14944 IDXI = IDXSTK(NSTK)
14945 * skip stable particles
14946 IF (ISTAB.EQ.1) THEN
14947 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14948 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
14949 ELSEIF (ISTAB.EQ.2) THEN
14950 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
14951 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14952 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14953 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14954 IF ( IDXI.EQ.109) GOTO 10
14955 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14956 ELSEIF (ISTAB.EQ.3) THEN
14957 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
14958 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14959 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14960 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14963 * calculate direction cosines and Lorentz-parameter of decaying part.
14964 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14965 PTOT = MAX(PTOT,TINY17)
14967 DCOS(I) = PI(NSTK,I)/PTOT
14969 GAM = PI(NSTK,4)/AAM(IDXI)
14970 BGAM = PTOT/AAM(IDXI)
14972 * get decay-channel
14976 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14978 * identities of secondaries
14979 IDX(1) = NZK(KCHAN,1)
14980 IDX(2) = NZK(KCHAN,2)
14981 IF (IDX(2).LT.1) GOTO 9999
14982 IDX(3) = NZK(KCHAN,3)
14984 * handle decay in rest system of decaying particle
14985 IF (IDX(3).EQ.0) THEN
14986 * two-particle decay
14988 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
14989 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14990 & AAM(IDX(1)),AAM(IDX(2)))
14992 * three-particle decay
14994 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
14995 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14996 & CODF(3),COFF(3),SIFF(3),
14997 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15001 * transform decay products back
15004 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15005 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15006 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15007 * add particle to stack
15008 IDXSTK(NSTK) = IDX(I)
15010 PI(NSTK,J) = DCOSF(J)*PFF(I)
15016 * stable particle, put to output-arrays
15019 POUT(NSEC,I) = PI(NSTK,I)
15021 IDXOUT(NSEC) = IDXSTK(NSTK)
15022 * store secondaries for energy-momentum conservation check
15024 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15025 & -POUT(NSEC,4),2,IDUM,IDUM)
15027 IF (NSTK.GT.0) GOTO 100
15029 * check energy-momentum conservation
15031 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15032 IF (IREJ1.NE.0) GOTO 9999
15042 *$ CREATE DT_DECAY1.FOR
15045 *===decay1=============================================================*
15047 SUBROUTINE DT_DECAY1
15049 ************************************************************************
15050 * Decay of resonances stored in DTEVT1. *
15051 * This version dated 20.01.95 is written by S. Roesler *
15052 ************************************************************************
15054 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15056 PARAMETER ( LINP = 10 ,
15061 PARAMETER (NMXHKK=200000)
15062 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15063 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15064 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15065 * extended event history
15066 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15067 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15070 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15073 C DO 1 I=NPOINT(5),NEND
15074 DO 1 I=NPOINT(4),NEND
15075 IF (ABS(ISTHKK(I)).EQ.1) THEN
15080 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15081 IF (NSEC.GT.1) THEN
15083 IDHAD = IDT_IPDGHA(IDXOUT(N))
15084 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15085 & POUT(N,3),POUT(N,4),0,0,0)
15094 *$ CREATE DT_DECPI0.FOR
15097 *===decpi0=============================================================*
15099 SUBROUTINE DT_DECPI0
15101 ************************************************************************
15102 * Decay of pi0 handled with JETSET. *
15103 * This version dated 18.02.96 is written by S. Roesler *
15104 ************************************************************************
15106 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15108 PARAMETER ( LINP = 10 ,
15111 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15114 PARAMETER (NMXHKK=200000)
15115 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15116 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15117 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15118 * extended event history
15119 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15120 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15122 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15123 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15124 PARAMETER (MAXLND=4000)
15125 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15126 * flags for input different options
15127 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15128 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15129 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15133 DIMENSION IHISMO(NMXHKK),P1(4)
15135 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15145 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15151 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15152 & PHKK(4,I),INI,IDUM,IDUM)
15153 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15154 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15155 COSTH = PHKK(3,I)/(PTOT+TINY10)
15156 IF (COSTH.GT.ONE) THEN
15158 ELSEIF (COSTH.LT.-ONE) THEN
15159 THETA = TWOPI/2.0D0
15161 THETA = ACOS(COSTH)
15163 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15164 IF (PHKK(1,I).LT.0.0D0)
15165 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15170 P(NN,5) = PHKK(5,I)
15171 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15180 IF (PYK(II,7).EQ.1) THEN
15182 P1(KK) = PYP(II,KK)
15185 MO = IHISMO(PYK(II,15))
15186 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15188 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15190 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15194 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15201 *$ CREATE DT_DTWOPD.FOR
15204 *===dtwopd=============================================================*
15206 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15207 & COF2,SIF2,AM1,AM2)
15209 ************************************************************************
15210 * Two-particle decay. *
15211 * UMO cm-energy of the decaying system (input) *
15212 * AM1/AM2 masses of the decay products (input) *
15213 * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15214 * COD,COF,SIF direction cosines of the decay prod. (output) *
15215 * Revised by S. Roesler, 20.11.95 *
15216 ************************************************************************
15218 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15220 PARAMETER ( LINP = 10 ,
15223 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15225 IF (UMO.LT.(AM1+AM2)) THEN
15226 WRITE(LOUT,1000) UMO,AM1,AM2
15227 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15232 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15234 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15236 CALL DT_DSFECF(SIF1,COF1)
15237 COD1 = TWO*DT_RNDM(PCM2)-ONE
15245 *$ CREATE DT_DTHREP.FOR
15248 *===dthrep=============================================================*
15250 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15251 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15253 ************************************************************************
15254 * Three-particle decay. *
15255 * UMO cm-energy of the decaying system (input) *
15256 * AM1/2/3 masses of the decay products (input) *
15257 * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15258 * COD,COF,SIF direction cosines of the decay prod. (output) *
15260 * Threpd89: slight revision by A. Ferrari *
15261 * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15262 * Revised by S. Roesler, 20.11.95 *
15263 ************************************************************************
15265 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15267 PARAMETER ( LINP = 10 ,
15271 PARAMETER ( ANGLSQ = 2.5D-31 )
15272 PARAMETER ( AZRZRZ = 1.0D-30 )
15273 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15274 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15275 PARAMETER ( ONEONE = 1.D+00 )
15276 PARAMETER ( TWOTWO = 2.D+00 )
15277 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15279 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15280 * flags for input different options
15281 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15282 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15283 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15285 DIMENSION F(5),XX(5)
15289 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15290 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15291 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15298 * UFAK=1.0000000000001D0
15299 * IF (GU.GT.GO) UFAK=0.9999999999999D0
15317 S22=GU+(I-1.D0)*DS2
15319 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15321 IF(RHO2.LT.RHO1) GO TO 125
15323 125 S2SUP=(S22-S21)*.5D0+S21
15324 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15326 SUPRHO=SUPRHO*1.05D0
15328 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15329 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15335 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15336 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15338 X4=(XX(1)+XX(2))*0.5D0
15339 X5=(XX(2)+XX(3))*0.5D0
15340 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15342 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15349 IF (F (II).GE.F (III)) GO TO 128
15362 IF (XX(II).GE.XX(III)) GO TO 129
15376 IF (ITH.GT.200) REDU=-9.D0
15377 IF (ITH.GT.200) GO TO 400
15379 * S2=AM23+C*((UMO-AM1)**2-AM23)
15380 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15383 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15384 IF(Y.GT.RHO) GO TO 1
15385 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15387 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15389 S3=UMO2+AM11+AM22+AM33-S1-S2
15390 ECM1=(UMO2+AM11-S2)/UMOO
15391 ECM2=(UMO2+AM22-S3)/UMOO
15392 ECM3=(UMO2+AM33-S1)/UMOO
15393 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15394 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15395 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15396 CALL DT_DSFECF(SFE,CFE)
15397 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15398 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15399 PCM12 = PCM1 * PCM2
15400 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15401 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15405 COSTH=(UW-0.5D+00)*2.D+00
15407 * IF(ABS(COSTH).GT.0.9999999999999999D0)
15408 * &COSTH=SIGN(0.9999999999999999D0,COSTH)
15409 IF(ABS(COSTH).GT.ONEONE)
15410 &COSTH=SIGN(ONEONE,COSTH)
15411 IF (REDU.LT.1.D+00) RETURN
15412 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15413 * IF(ABS(COSTH2).GT.0.9999999999999999D0)
15414 * &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15415 IF(ABS(COSTH2).GT.ONEONE)
15416 &COSTH2=SIGN(ONEONE,COSTH2)
15417 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15418 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15419 SINTH1=COSTH2*SINTH-COSTH*SINTH2
15420 COSTH1=COSTH*COSTH2+SINTH2*SINTH
15421 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15422 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15423 C***THE DIRECTION OF PARTICLE 3
15424 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15431 CALL DT_DSFECF(SIF3,COF3)
15432 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15433 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15435 COD1=CX11*COD3+CZ11*SID3
15436 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15437 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15440 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15441 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15442 COD2=CX22*COD3+CZ22*SID3
15443 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15444 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15445 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15447 * === Energy conservation check: === *
15448 EOCHCK = UMO - ECM1 - ECM2 - ECM3
15449 * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15450 * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15451 * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15452 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15453 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15454 & + PCM3 * COF3 * SID3
15455 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15456 & + PCM3 * SIF3 * SID3
15457 EOCMPR = 1.D-12 * UMO
15458 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15459 & .GT. EOCMPR ) THEN
15460 **sr 5.5.95 output-unit changed
15461 IF (IOULEV(1).GT.0) THEN
15463 & ' *** Threpd: energy/momentum conservation failure! ***',
15464 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
15465 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15472 *$ CREATE DT_DBKLAS.FOR
15475 *===dbklas=============================================================*
15477 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15479 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15481 PARAMETER ( LINP = 10 ,
15485 * quark-content to particle index conversion (DTUNUC 1.x)
15486 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15487 & IA08(6,21),IA10(6,21)
15492 CALL DT_INDEXD(J,K,IND)
15495 IF (I8.LE.0) I8 = I10
15502 CALL DT_INDEXD(JJ,KK,IND)
15505 IF (I8.LE.0) I8 = I10
15510 *$ CREATE DT_INDEXD.FOR
15513 *===indexd=============================================================*
15515 SUBROUTINE DT_INDEXD(KA,KB,IND)
15517 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15519 PARAMETER ( LINP = 10 ,
15528 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15530 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15531 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15532 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15534 IF (KP.EQ.10) IND=10
15535 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15536 IF (KP.EQ.9) IND=12
15537 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15538 IF (KP.EQ.15) IND=14
15539 IF (KP.EQ.18) IND=15
15540 IF (KP.EQ.16) IND=16
15541 IF (KP.EQ.20) IND=17
15542 IF (KP.EQ.24) IND=18
15543 IF (KP.EQ.25) IND=19
15544 IF (KP.EQ.30) IND=20
15545 IF (KP.EQ.36) IND=21
15550 *$ CREATE DT_DCHANT.FOR
15553 *===dchant=============================================================*
15555 SUBROUTINE DT_DCHANT
15557 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15559 PARAMETER ( LINP = 10 ,
15562 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15564 * HADRIN: decay channel information
15565 PARAMETER (IDMAX9=602)
15567 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15568 * particle properties (BAMJET index convention)
15570 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15571 & IICH(210),IIBAR(210),K1(210),K2(210)
15573 DIMENSION HWT(IDMAX9)
15575 * change of weights wt from absolut values into the sum of wt of a dec.
15580 C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15581 C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15582 C & K1(KKK),K2(KKK)
15593 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15594 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15604 *$ CREATE DT_DDATAR.FOR
15607 *===ddatar=============================================================*
15609 SUBROUTINE DT_DDATAR
15611 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15613 PARAMETER ( LINP = 10 ,
15616 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15618 * quark-content to particle index conversion (DTUNUC 1.x)
15619 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15620 & IA08(6,21),IA10(6,21)
15622 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15624 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
15625 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
15627 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
15628 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
15630 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
15631 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
15632 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
15633 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
15634 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
15635 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
15636 & 0, 0, 0,140,137,138,146, 0, 0,142,
15637 & 139,147, 0, 0,145,148, 50*0/
15638 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
15639 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
15640 & 0, 54, 55,105,162, 0, 0, 56,106,163,
15641 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
15642 & 0, 0,104,105,107,164, 0, 0,106,108,
15643 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
15644 & 0, 0, 0,161,162,164,167, 0, 0,163,
15645 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
15646 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
15647 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
15648 & 0, 2, 9,100,149, 0, 0, 0,101,154,
15649 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
15650 & 0, 0, 99,100,102,150, 0, 0,101,103,
15651 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
15652 & 0, 0, 0,152,149,150,158, 0, 0,154,
15653 & 151,159, 0, 0,157,160, 50*0/
15654 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
15655 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
15656 & 0, 68, 69,111,172, 0, 0, 70,112,173,
15657 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
15658 & 0, 0,110,111,113,174, 0, 0,112,114,
15659 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
15660 & 0, 0, 0,171,172,174,177, 0, 0,173,
15661 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
15697 *$ CREATE DT_INITJS.FOR
15700 *===initjs=============================================================*
15702 SUBROUTINE DT_INITJS(MODE)
15704 ************************************************************************
15705 * Initialize JETSET paramters. *
15706 * MODE = 0 default settings *
15707 * = 1 PHOJET settings *
15708 * = 2 DTUNUC settings *
15709 * This version dated 16.02.96 is written by S. Roesler *
15711 * Last change 27.12.2006 by S. Roesler. *
15712 ************************************************************************
15714 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15716 PARAMETER ( LINP = 10 ,
15719 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15721 LOGICAL LFIRST,LFIRDT,LFIRPH
15723 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15724 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15725 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15726 * flags for particle decays
15727 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15728 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15729 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15730 * flags for input different options
15731 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15732 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15733 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15737 DIMENSION IDXSTA(40)
15739 * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
15740 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15741 * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
15742 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
15743 * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15744 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15745 * Ksic0 aKsic+aKsic0 sig0 asig0
15746 & 4132,-4232,-4132, 3212,-3212, 5*0/
15748 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15751 * save default settings
15763 * LUJETS / PYJETS array-dimensions
15765 * increase maximum number of JETSET-error prints
15767 * prevent particles decaying
15770 KC = PYCOMP(IDXSTA(I))
15777 C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15778 C & (I.EQ.8).OR.(I.EQ.10)) THEN
15779 C ELSEIF (I.EQ.4) THEN
15783 C AM MDCY(KC,1) = 0
15786 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15787 KC = PYCOMP(IDXSTA(I))
15789 C AM MDCY(KC,1) = 0
15796 IF (PDB.LE.ZERO) THEN
15797 * no popcorn-mechanism
15803 * set JETSET-parameter requested by input cards
15804 IF (NMSTU.GT.0) THEN
15806 MSTU(IMSTU(I)) = MSTUX(I)
15809 IF (NMSTJ.GT.0) THEN
15811 MSTJ(IMSTJ(I)) = MSTJX(I)
15814 IF (NPARU.GT.0) THEN
15816 PARU(IPARU(I)) = PARUX(I)
15822 * PARJ(1) suppression of qq-aqaq pair prod. compared to
15823 * q-aq pair prod. (default: 0.1)
15824 * PARJ(2) strangeness suppression (default: 0.3)
15825 * PARJ(3) extra suppression of strange diquarks (default: 0.4)
15826 * PARJ(6) extra suppression of sas-pair shared by B and
15827 * aB in BMaB (default: 0.5)
15828 * PARJ(7) extra suppression of strange meson M in BMaB
15829 * configuration (default: 0.5)
15830 * PARJ(18) spin 3/2 baryon suppression (default: 1.0)
15831 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15832 * momentum distrib. for prim. hadrons (default: 0.35)
15833 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15834 * function (default: 0.9 GeV^-2)
15837 IF (MODE.EQ.1) THEN
15844 C PARJ(18) = PDEF18
15845 C PARJ(21) = PDEF21
15846 C PARJ(42) = PDEF42
15847 **sr 18.11.98 parameter tuning
15848 C PARJ(1) = 0.092D0
15852 C PARJ(21) = 0.45D0
15854 **sr 28.04.99 parameter tuning (May 99 minor modifications)
15864 IF (NPARJ.GT.0) THEN
15866 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15870 WRITE(LOUT,'(1X,A)')
15871 & 'DT_INITJS: JETSET-parameter for PHOJET'
15876 ELSEIF (MODE.EQ.2) THEN
15877 IF (IFRAG(2).EQ.1) THEN
15878 **sr parameters before 9.3.96
15883 C PARJ(21) = 0.55D0
15885 **sr 18.11.98 parameter tuning
15890 C PARJ(21) = 0.45D0
15892 **sr 28.04.99 parameter tuning
15900 IF (NPARJ.GT.0) THEN
15902 IF (IPARJ(I).LT.0) THEN
15903 IDX = ABS(IPARJ(I))
15904 PARJ(IDX) = PARJX(I)
15909 WRITE(LOUT,'(1X,A)')
15910 & 'DT_INITJS: JETSET-parameter for DTUNUC'
15914 ELSEIF (IFRAG(2).EQ.2) THEN
15921 C PARJ(21) = 0.55D0
15952 *$ CREATE DT_JSPARA.FOR
15955 *===jspara=============================================================*
15957 SUBROUTINE DT_JSPARA(MODE)
15959 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15961 PARAMETER ( LINP = 10 ,
15964 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15965 & ONE=1.0D0,ZERO=0.0D0)
15969 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15971 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15973 DATA LFIRST /.TRUE./
15975 * save the default JETSET-parameter on the first call
15987 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
15989 * compare the default JETSET-parameter with the present values
15991 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
15992 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
15993 C ISTU(I) = MSTU(I)
15995 DIFF = ABS(PARU(I)-QARU(I))
15996 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
15997 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
15998 C QARU(I) = PARU(I)
16000 IF (MSTJ(I).NE.ISTJ(I)) THEN
16001 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16002 C ISTJ(I) = MSTJ(I)
16004 DIFF = ABS(PARJ(I)-QARJ(I))
16005 IF (DIFF.GE.1.0D-5) THEN
16006 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16007 C QARJ(I) = PARJ(I)
16010 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16011 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16016 *$ CREATE DT_FOZOCA.FOR
16019 *===fozoca=============================================================*
16021 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16023 ************************************************************************
16024 * This subroutine treats the complete FOrmation ZOne supressed intra- *
16025 * nuclear CAscade. *
16026 * LFZC = .true. cascade has been treated *
16027 * = .false. cascade skipped *
16028 * This is a completely revised version of the original FOZOKL. *
16029 * This version dated 18.11.95 is written by S. Roesler *
16030 ************************************************************************
16032 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16034 PARAMETER ( LINP = 10 ,
16037 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16038 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16040 LOGICAL LSTART,LCAS,LFZC
16043 PARAMETER (NMXHKK=200000)
16044 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16045 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16046 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16047 * extended event history
16048 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16049 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16051 * rejection counter
16052 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16053 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16054 & IREXCI(3),IRDIFF(2),IRINC
16055 * properties of interacting particles
16056 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16057 * Glauber formalism: collision properties
16058 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16059 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16060 * flags for input different options
16061 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16062 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16063 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16064 * final state after intranuclear cascade step
16065 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16066 * parameter for intranuclear cascade
16068 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16070 DIMENSION NCWOUN(2)
16072 DATA LSTART /.TRUE./
16077 * skip cascade if hadron-hadron interaction or if supressed by user
16078 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16079 * skip cascade if not all possible chains systems are hadronized
16081 IF (.NOT.LHADRO(I)) GOTO 9999
16085 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16086 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16087 & 'maximum of',I4,' generations',/,10X,'formation time ',
16088 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16089 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16090 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16091 1001 FORMAT(10X,'p_t dependent formation zone',/)
16092 1002 FORMAT(10X,'constant formation zone',/)
16096 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16097 * which may interact with final state particles are stored in a seperate
16098 * array - here all proj./target nucleon-indices (just for simplicity)
16100 DO 9 I=1,NPOINT(1)-1
16105 * initialize Pauli-principle treatment (find wounded nucleons)
16112 IF (ISTHKK(J).EQ.10+I) THEN
16113 NWOUND(I) = NWOUND(I)+1
16114 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16115 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16120 * modify nuclear potential for wounded nucleons
16121 IPRCL = IP -NWOUND(1)
16122 IPZRCL = IPZ-NCWOUN(1)
16123 ITRCL = IT -NWOUND(2)
16124 ITZRCL = ITZ-NCWOUN(2)
16125 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16133 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16134 * select nucleus the cascade starts first (proj. - 1, target - -1)
16136 * projectile/target with probab. 1/2
16137 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16138 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16139 * in the nucleus with highest mass
16140 ELSEIF (INCMOD.EQ.2) THEN
16143 ELSEIF (IP.EQ.IT) THEN
16144 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16146 * the nucleus the cascade starts first is requested to be the one
16147 * moving in the direction of the secondary
16148 ELSEIF (INCMOD.EQ.3) THEN
16149 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16151 * check that the selected "nucleus" is not a hadron
16152 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16153 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
16155 * treat intranuclear cascade in the nucleus selected first
16157 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16158 IF (IREJ1.NE.0) GOTO 9998
16159 * treat intranuclear cascade in the other nucleus if this isn't a had.
16161 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16162 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
16163 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16164 IF (IREJ1.NE.0) GOTO 9998
16172 IF (NSTART.LE.NEND) GOTO 7
16177 * reject this event
16182 * intranucl. cascade not treated because of interaction properties or
16183 * it is supressed by user or it was rejected or...
16185 * reset flag characterizing direction of motion in n-n-cms
16187 C DO 9990 I=NPOINT(5),NHKK
16188 C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16194 *$ CREATE DT_INUCAS.FOR
16197 *===inucas=============================================================*
16199 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16201 ************************************************************************
16202 * Formation zone supressed IntraNUclear CAScade for one final state *
16204 * IT, IP mass numbers of target, projectile nuclei *
16205 * IDXCAS index of final state particle in DTEVT1 *
16206 * NCAS = 1 intranuclear cascade in projectile *
16207 * = -1 intranuclear cascade in target *
16208 * This version dated 18.11.95 is written by S. Roesler *
16209 ************************************************************************
16211 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16213 PARAMETER ( LINP = 10 ,
16217 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16218 & OHALF=0.5D0,ONE=1.0D0)
16219 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16220 PARAMETER (TWOPI=6.283185307179586454D+00)
16221 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16223 LOGICAL LABSOR,LCAS
16226 PARAMETER (NMXHKK=200000)
16227 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16228 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16229 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16230 * extended event history
16231 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16232 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16234 * final state after inc step
16235 PARAMETER (MAXFSP=10)
16236 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16237 * flags for input different options
16238 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16239 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16240 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16241 * particle properties (BAMJET index convention)
16243 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16244 & IICH(210),IIBAR(210),K1(210),K2(210)
16245 * Glauber formalism: collision properties
16246 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16247 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16248 * nuclear potential
16250 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16251 & EBINDP(2),EBINDN(2),EPOT(2,210),
16252 & ETACOU(2),ICOUL,LFERMI
16253 * parameter for intranuclear cascade
16255 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16256 * final state after intranuclear cascade step
16257 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16258 * nucleon-nucleon event-generator
16261 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16262 * statistics: residual nuclei
16263 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16264 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16265 & NINCST(2,4),NINCEV(2),
16266 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16267 & NRESPB(2),NRESCH(2),NRESEV(4),
16268 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16271 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16272 & PCAS1(5),PNUC(5),BGTA(4),
16273 & BGCAS(2),GACAS(2),BECAS(2),
16274 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16276 DATA PDIF /0.545D0/
16281 IF (NINCEV(1).NE.NEVHKK) THEN
16283 NINCEV(2) = NINCEV(2)+1
16286 * "BAMJET-index" of this hadron
16287 IDCAS = IDBAM(IDXCAS)
16288 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16290 * skip gammas, electrons, etc..
16291 IF (AAM(IDCAS).LT.TINY2) RETURN
16293 * Lorentz-trsf. into projectile rest system
16295 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16296 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16297 & PCAS(1,4),IDCAS,-2)
16298 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16299 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16300 IF (PCAS(1,5).GT.ZERO) THEN
16301 PCAS(1,5) = SQRT(PCAS(1,5))
16303 PCAS(1,5) = AAM(IDCAS)
16306 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16308 * Lorentz-parameters
16309 * particle rest system --> projectile rest system
16310 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16311 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16312 BECAS(1) = BGCAS(1)/GACAS(1)
16316 IF (K.LE.3) COSCAS(1,K) = ZERO
16323 * Lorentz-trsf. into target rest system
16325 * LEPTO: final state particles are already in target rest frame
16326 C IF (MCGENE.EQ.3) THEN
16327 C PCAS(2,1) = PHKK(1,IDXCAS)
16328 C PCAS(2,2) = PHKK(2,IDXCAS)
16329 C PCAS(2,3) = PHKK(3,IDXCAS)
16330 C PCAS(2,4) = PHKK(4,IDXCAS)
16332 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16333 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16334 & PCAS(2,4),IDCAS,-3)
16336 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16337 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16338 IF (PCAS(2,5).GT.ZERO) THEN
16339 PCAS(2,5) = SQRT(PCAS(2,5))
16341 PCAS(2,5) = AAM(IDCAS)
16344 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16346 * Lorentz-parameters
16347 * particle rest system --> target rest system
16348 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16349 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16350 BECAS(2) = BGCAS(2)/GACAS(2)
16354 IF (K.LE.3) COSCAS(2,K) = ZERO
16362 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16363 * potential (see CONUCL)
16364 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
16365 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
16366 * impact parameter (the projectile moving along z)
16368 BIMPC(2) = BIMPAC*FM2MM
16370 * get position of initial hadron in projectile/target rest-syst.
16372 VTXCAS(1,K) = WHKK(K,IDXCAS)
16373 VTXCAS(2,K) = VHKK(K,IDXCAS)
16378 IF (NCAS.EQ.-1) THEN
16383 IF (PTOCAS(ICAS).LT.TINY10) THEN
16384 WRITE(LOUT,1000) PTOCAS
16385 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
16386 & ' hadron ',/,20X,2E12.4)
16390 * reset spectator flags
16397 * formation length (in fm)
16401 DEL0 = TAUFOR*BGCAS(ICAS)
16402 IF (ITAUVE.EQ.1) THEN
16403 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16404 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16407 * sample from exp(-del/del0)
16408 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16409 * save formation time
16410 TAUSA1 = DEL1/BGCAS(ICAS)
16411 REL1 = TAUSA1*BGCAS(I2)
16414 TAUSAM = DEL/BGCAS(ICAS)
16415 REL = TAUSAM*BGCAS(I2)
16417 * special treatment for negative particles unable to escape
16418 * nuclear potential (implemented for ap, pi-, K- only)
16420 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16421 * threshold energy = nuclear potential + Coulomb potential
16422 * (nuclear potential for hadron-nucleus interactions only)
16423 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16424 IF (PCAS(ICAS,4).LT.ETHR) THEN
16426 PCAS1(K) = PCAS(ICAS,K)
16428 * "absorb" negative particle in nucleus
16429 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16430 IF (IREJ1.NE.0) GOTO 9999
16431 IF (NSPE.GE.1) LABSOR = .TRUE.
16435 * if the initial particle has not been absorbed proceed with
16437 IF (.NOT.LABSOR) THEN
16439 * calculate coordinates of hadron at the end of the formation zone
16440 * transport-time and -step in the rest system where this step is
16443 DTIME = DSTEP/BECAS(ICAS)
16445 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16446 RTIME = RSTEP/BECAS(I2)
16450 * save step whithout considering the overlapping region
16451 DSTEP1 = DEL1*FM2MM
16452 DTIME1 = DSTEP1/BECAS(ICAS)
16453 RSTEP1 = REL1*FM2MM
16454 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16455 RTIME1 = RSTEP1/BECAS(I2)
16459 * transport to the end of the formation zone in this system
16461 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16462 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
16463 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16464 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
16466 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16467 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
16468 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16469 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
16471 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16472 XCAS = VTXCAS(ICAS,1)
16473 YCAS = VTXCAS(ICAS,2)
16474 XNCLTA = BIMPAC*FM2MM
16475 RNCLPR = (RPROJ+RNUCLE)*FM2MM
16476 RNCLTA = (RTARG+RNUCLE)*FM2MM
16477 C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16478 C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16479 C RNCLPR = (RPROJ)*FM2MM
16480 C RNCLTA = (RTARG)*FM2MM
16481 RCASPR = SQRT( XCAS**2 +YCAS**2)
16482 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16483 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16484 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16488 * check if particle is already outside of the corresp. nucleus
16489 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16490 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16491 IF (RDIST.GE.RNUC(ICAS)) THEN
16492 * here: IDCH is the generation of the final state part. starting
16493 * with zero for hadronization products
16494 * flag particles of generation 0 being outside the nuclei after
16495 * formation time (to be used for excitation energy calculation)
16496 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16497 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16506 * already here: skip particles being outside HADRIN "energy-window"
16507 * to avoid wasting of time
16508 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16509 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16510 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16511 C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16512 C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
16513 C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16514 C & E12.4,', above or below HADRIN-thresholds',I6)
16519 DO 7 IDXHKK=1,NOINC
16521 * scan DTEVT1 for unwounded or excited nucleons
16522 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16524 IF (ICAS.EQ.1) THEN
16525 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16526 ELSEIF (ICAS.EQ.2) THEN
16527 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16530 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16531 & VTXDST(2)*COSCAS(ICAS,2)+
16532 & VTXDST(3)*COSCAS(ICAS,3)
16533 * check if nucleon is situated in forward direction
16534 IF (POSNUC.GT.ZERO) THEN
16535 * distance between hadron and this nucleon
16536 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16539 BIMNU2 = DISTNU**2-POSNUC**2
16540 IF (BIMNU2.LT.ZERO) THEN
16541 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16542 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
16543 & ' parameter ',/,20X,3E12.4)
16546 BIMNU = SQRT(BIMNU2)
16547 * maximum impact parameter to have interaction
16548 IDNUC = IDT_ICIHAD(IDHKK(I))
16549 IDNUC1 = IDT_MCHAD(IDNUC)
16550 IDCAS1 = IDT_MCHAD(IDCAS)
16552 PCAS1(K) = PCAS(ICAS,K)
16553 PNUC(K) = PHKK(K,I)
16555 * Lorentz-parameter for trafo into rest-system of target
16557 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16559 * transformation of projectile into rest-system of target
16560 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16561 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16562 & PPTOT,PX,PY,PZ,PE)
16564 C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16565 C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16567 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16568 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16569 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16570 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16571 SIGIN = SIGTOT-SIGEL-SIGAB
16572 C SIGTOT = SIGIN+SIGEL+SIGAB
16574 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16575 * check if interaction is possible
16576 IF (BIMNU.LE.BIMMAX) THEN
16577 * get nucleon with smallest distance and kind of interaction
16578 * (elastic/inelastic)
16579 IF (DISTNU.LT.DIST) THEN
16582 IF (IDNUC.NE.IDSPE(1)) THEN
16583 IDSPE(2) = IDSPE(1)
16584 IDXSPE(2) = IDXSPE(1)
16593 C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16595 C STOT = SIGIN+SIGEL
16597 C SELA = SIGEL+0.75D0*SIGIN
16598 C STOT = 0.25D0*SIGIN+SELA
16604 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16606 IDNUC = IDT_ICIHAD(IDHKK(I))
16607 IF (IDNUC.EQ.1) THEN
16608 IF (DISTNU.LT.DISTP) THEN
16613 ELSEIF (IDNUC.EQ.8) THEN
16614 IF (DISTNU.LT.DISTN) THEN
16623 * there is no nucleon for a secondary interaction
16624 IF (NSPE.EQ.0) GOTO 9997
16626 C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16627 C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16628 IF (IDXSPE(2).EQ.0) THEN
16629 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16631 C IF (ICAS.EQ.1) THEN
16632 C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16633 C ELSEIF (ICAS.EQ.2) THEN
16634 C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16637 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16639 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16646 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16648 C IF (ICAS.EQ.1) THEN
16649 C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16650 C ELSEIF (ICAS.EQ.2) THEN
16651 C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16654 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16656 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16669 IF (RR.LT.SELA/STOT) THEN
16671 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16678 PCAS1(K) = PCAS(ICAS,K)
16679 PNUC(K) = PHKK(K,IDXSPE(1))
16681 IF (IPROC.EQ.3) THEN
16682 * 2-nucleon absorption of pion
16684 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16685 IF (IREJ1.NE.0) GOTO 9999
16686 IF (NSPE.GE.1) LABSOR = .TRUE.
16688 * sample secondary interaction
16689 IDNUC = IDBAM(IDXSPE(1))
16690 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16691 IF (IREJ1.EQ.1) GOTO 9999
16692 IF (IREJ1.GT.1) GOTO 9998
16696 * update arrays to include Pauli-principle
16698 IF (NWOUND(ICAS).LE.299) THEN
16699 NWOUND(ICAS) = NWOUND(ICAS)+1
16700 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16704 * dump initial hadron for energy-momentum conservation check
16706 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16707 & PCAS(ICAS,4),1,IDUM,IDUM)
16709 * dump final state particles into DTEVT1
16711 * check if Pauli-principle is fulfilled
16713 NWTMP(1) = NWOUND(1)
16714 NWTMP(2) = NWOUND(2)
16718 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16719 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16721 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16728 IF (IDX.EQ.1) MODE = -1
16729 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16731 * first check if cascade step is forbidden due to Pauli-principle
16732 * (in case of absorpion this step is forced)
16733 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16734 & (IDFSP(I).EQ.8))) THEN
16735 * get nuclear potential barrier
16736 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16737 IF (IDFSP(I).EQ.1) THEN
16738 POTLOW = POT-EBINDP(IDX)
16740 POTLOW = POT-EBINDN(IDX)
16742 * final state particle not able to escape nucleus
16743 IF (PE.LE.POTLOW) THEN
16744 * check if there are wounded nucleons
16745 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16746 & EWOUND(IDX,NWOUND(IDX)))) THEN
16748 NWOUND(IDX) = NWOUND(IDX)-1
16750 * interaction prohibited by Pauli-principle
16751 NWOUND(1) = NWTMP(1)
16752 NWOUND(2) = NWTMP(2)
16761 NWOUND(1) = NWTMP(1)
16762 NWOUND(2) = NWTMP(2)
16766 IST = ISTHKK(IDXCAS)
16770 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16771 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16773 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16778 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16780 * first check if cascade step is forbidden due to Pauli-principle
16781 * (in case of absorpion this step is forced)
16782 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16783 & (IDFSP(I).EQ.8))) THEN
16784 * get nuclear potential barrier
16785 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16786 IF (IDFSP(I).EQ.1) THEN
16787 POTLOW = POT-EBINDP(IDX)
16789 POTLOW = POT-EBINDN(IDX)
16791 * final state particle not able to escape nucleus
16792 IF (PE.LE.POTLOW) THEN
16793 * check if there are wounded nucleons
16794 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16795 & EWOUND(IDX,NWOUND(IDX)))) THEN
16796 NWOUND(IDX) = NWOUND(IDX)-1
16800 * interaction prohibited by Pauli-principle
16801 NWOUND(1) = NWTMP(1)
16802 NWOUND(2) = NWTMP(2)
16806 c ELSEIF (PE.LE.POT) THEN
16807 cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16808 cC NWOUND(IDX) = NWOUND(IDX)-1
16810 c NPAULI = NPAULI+1
16816 * dump final state particles for energy-momentum conservation check
16817 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16818 & -PFSP(4,I),2,IDUM,IDUM)
16824 IF (ABS(IST).EQ.1) THEN
16825 * transform particles back into n-n cms
16826 * LEPTO: leave final state particles in target rest frame
16827 C IF (MCGENE.EQ.3) THEN
16834 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16835 & PFSP(4,I),IDFSP(I),IMODE)
16837 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16838 * target cascade but fsp got stuck in proj. --> transform it into
16839 * proj. rest system
16840 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16841 & PFSP(4,I),IDFSP(I),-1)
16842 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16843 * proj. cascade but fsp got stuck in target --> transform it into
16844 * target rest system
16845 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16846 & PFSP(4,I),IDFSP(I),1)
16849 * dump final state particles into DTEVT1
16850 IGEN = IDCH(IDXCAS)+1
16851 ID = IDT_IPDGHA(IDFSP(I))
16853 IF (LABSOR) IXR = 99
16854 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16855 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16857 * update the counter for particles which got stuck inside the nucleus
16858 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16860 IDXINC(NOINC) = NHKK
16863 * in case of absorption the spatial treatment is an approximate
16864 * solution anyway (the positions of the nucleons which "absorb" the
16865 * cascade particle are not taken into consideration) therefore the
16866 * particles are produced at the position of the cascade particle
16868 WHKK(K,NHKK) = WHKK(K,IDXCAS)
16869 VHKK(K,NHKK) = VHKK(K,IDXCAS)
16872 * DDISTL - distance the cascade particle moves to the intera. point
16873 * (the position where impact-parameter = distance to the interacting
16874 * nucleon), DIST - distance to the interacting nucleon at the time of
16875 * formation of the cascade particle, BINT - impact-parameter of this
16876 * cascade-interaction
16877 DDISTL = SQRT(DIST**2-BINT**2)
16878 DTIME = DDISTL/BECAS(ICAS)
16879 DTIMEL = DDISTL/BGCAS(ICAS)
16880 RDISTL = DTIMEL*BGCAS(I2)
16881 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16882 RTIME = RDISTL/BECAS(I2)
16886 * RDISTL, RTIME are this step and time in the rest system of the other
16889 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16890 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
16892 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16893 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
16894 * position of particle production is half the impact-parameter to
16895 * the interacting nucleon
16897 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16898 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16900 * time of production of secondary = time of interaction
16901 WHKK(4,NHKK) = VTXCA1(1,4)
16902 VHKK(4,NHKK) = VTXCA1(2,4)
16907 * modify status and position of cascade particle (the latter for
16908 * statistics reasons only)
16910 IF (LABSOR) ISTHKK(IDXCAS) = 19
16911 IF (.NOT.LABSOR) THEN
16913 WHKK(K,IDXCAS) = VTXCA1(1,K)
16914 VHKK(K,IDXCAS) = VTXCA1(2,K)
16920 * dump interacting nucleons for energy-momentum conservation check
16922 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16924 * modify entry for interacting nucleons
16925 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16926 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16928 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16929 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16933 * check energy-momentum conservation
16935 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16936 IF (IREJ1.NE.0) GOTO 9999
16941 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16943 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16944 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16951 * transport-step but no cascade step due to configuration (i.e. there
16952 * is no nucleon for interaction etc.)
16955 C WHKK(K,IDXCAS) = VTXCAS(1,K)
16956 C VHKK(K,IDXCAS) = VTXCAS(2,K)
16957 WHKK(K,IDXCAS) = VTXCA1(1,K)
16958 VHKK(K,IDXCAS) = VTXCA1(2,K)
16963 * no cascade-step because of configuration
16964 * (i.e. hadron outside nucleus etc.)
16974 *$ CREATE DT_ABSORP.FOR
16977 *===absorp=============================================================*
16979 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16981 ************************************************************************
16982 * Two-nucleon absorption of antiprotons, pi-, and K-. *
16983 * Antiproton absorption is handled by HADRIN. *
16984 * The following channels for meson-absorption are considered: *
16985 * pi- + p + p ---> n + p *
16986 * pi- + p + n ---> n + n *
16987 * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
16988 * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
16989 * K- + p + p ---> sigma- + n *
16990 * IDCAS, PCAS identity, momentum of particle to be absorbed *
16991 * NCAS = 1 intranuclear cascade in projectile *
16992 * = -1 intranuclear cascade in target *
16993 * NSPE number of spectator nucleons involved *
16994 * IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
16995 * Revised version of the original STOPIK written by HJM and J. Ranft. *
16996 * This version dated 24.02.95 is written by S. Roesler *
16997 ************************************************************************
16999 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17001 PARAMETER ( LINP = 10 ,
17004 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17005 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17008 PARAMETER (NMXHKK=200000)
17009 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17010 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17011 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17012 * extended event history
17013 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17014 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17016 * flags for input different options
17017 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17018 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17019 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17020 * final state after inc step
17021 PARAMETER (MAXFSP=10)
17022 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17023 * particle properties (BAMJET index convention)
17025 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17026 & IICH(210),IIBAR(210),K1(210),K2(210)
17028 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17029 & PTOT3P(4),BG3P(4),
17030 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17035 * skip particles others than ap, pi-, K- for mode=0
17036 IF ((MODE.EQ.0).AND.
17037 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17038 * skip particles others than pions for mode=1
17039 * (2-nucleon absorption in intranuclear cascade)
17040 IF ((MODE.EQ.1).AND.
17041 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17044 IF (NUCAS.EQ.-1) NUCAS = 2
17046 IF (MODE.EQ.0) THEN
17047 * scan spectator nucleons for nucleons being able to "absorb"
17052 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17055 IDSPE(NSPE) = IDBAM(I)
17056 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17057 IF (NSPE.EQ.2) THEN
17058 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17059 & (IDSPE(2).EQ.8)) THEN
17060 * there is no pi-+n+n channel
17072 * transform excited projectile nucleons (status=15) into proj. rest s.
17075 PSPE(I,K) = PHKK(K,IDXSPE(I))
17079 * antiproton absorption
17080 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17082 PSPE1(K) = PSPE(1,K)
17084 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17085 IF (IREJ1.NE.0) GOTO 9999
17088 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17089 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17090 IF (IDCAS.EQ.14) THEN
17094 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17095 ELSEIF (IDCAS.EQ.13) THEN
17099 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17100 ELSEIF (IDCAS.EQ.23) THEN
17102 IDFSP(1) = IDSPE(1)
17103 IDFSP(2) = IDSPE(2)
17104 ELSEIF (IDCAS.EQ.16) THEN
17107 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17108 IF (R.LT.ONETHI) THEN
17111 ELSEIF (R.LT.TWOTHI) THEN
17118 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17122 IF (R.LT.ONETHI) THEN
17125 ELSEIF (R.LT.TWOTHI) THEN
17134 * dump initial particles for energy-momentum cons. check
17136 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17137 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17139 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17142 * get Lorentz-parameter of 3 particle initial state
17144 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17146 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17147 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17149 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17151 * 2-particle decay of the 3-particle compound system
17152 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17153 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17154 & AAM(IDFSP(1)),AAM(IDFSP(2)))
17156 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17157 PX = PCMF(I)*COFF(I)*SDF
17158 PY = PCMF(I)*SIFF(I)*SDF
17159 PZ = PCMF(I)*CODF(I)
17160 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17161 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17163 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17164 * check consistency of kinematics
17165 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17166 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17167 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
17168 & ' tree-particle kinematics',/,20X,'id: ',I3,
17169 & ' AAM = ',E10.4,' MFSP = ',E10.4)
17171 * dump final state particles for energy-momentum cons. check
17172 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17173 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17177 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17178 IF (IREJ1.NE.0) THEN
17179 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17185 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17186 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
17187 & ' impossible',/,20X,'too few spectators (',I2,')')
17194 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17199 *$ CREATE DT_HADRIN.FOR
17202 *===hadrin=============================================================*
17204 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17206 ************************************************************************
17207 * Interface to the HADRIN-routines for inelastic and elastic *
17209 * IDPR,PPR(5) identity, momentum of projectile *
17210 * IDTA,PTA(5) identity, momentum of target *
17211 * MODE = 1 inelastic interaction *
17212 * = 2 elastic interaction *
17213 * Revised version of the original FHAD. *
17214 * This version dated 27.10.95 is written by S. Roesler *
17215 ************************************************************************
17217 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17219 PARAMETER ( LINP = 10 ,
17222 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17223 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17225 LOGICAL LCORR,LMSSG
17227 * flags for input different options
17228 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17229 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17230 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17231 * final state after inc step
17232 PARAMETER (MAXFSP=10)
17233 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17234 * particle properties (BAMJET index convention)
17236 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17237 & IICH(210),IIBAR(210),K1(210),K2(210)
17238 * output-common for DHADRI/ELHAIN
17239 * final state from HADRIN interaction
17240 PARAMETER (MAXFIN=10)
17241 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17242 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17244 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17245 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17247 DATA LMSSG /.TRUE./
17256 * dump initial particles for energy-momentum cons. check
17258 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17259 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17262 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17263 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17264 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17265 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17266 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17267 IF (LMSSG.AND.(IOULEV(3).GT.0))
17268 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17269 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
17270 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17271 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17276 * convert initial state particles into particles which can be
17277 * handled by HADRIN
17280 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17281 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17288 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17289 IF (IREJ1.GT.0) THEN
17290 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17297 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17298 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17301 * Lorentz-parameter for trafo into rest-system of target
17303 BGTA(K) = PTA(K)/PTA(5)
17305 * transformation of projectile into rest-system of target
17306 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17307 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17310 * direction cosines of projectile in target rest system
17311 CX = PPR1(1)/PPRTO1
17312 CY = PPR1(2)/PPRTO1
17313 CZ = PPR1(3)/PPRTO1
17315 * sample inelastic interaction
17316 IF (MODE.EQ.1) THEN
17317 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17318 IF (IRH.EQ.1) GOTO 9998
17319 * sample elastic interaction
17320 ELSEIF (MODE.EQ.2) THEN
17321 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17322 IF (IREJ1.NE.0) THEN
17323 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17326 IF (IRH.EQ.1) GOTO 9998
17328 WRITE(LOUT,1001) MODE,INTHAD
17329 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
17330 & I4,' (INTHAD =',I4,')')
17334 * transform final state particles back into Lab.
17337 PX = CXRH(I)*PLRH(I)
17338 PY = CYRH(I)*PLRH(I)
17339 PZ = CZRH(I)*PLRH(I)
17340 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17341 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17342 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17343 IDFSP(NFSP) = ITRH(I)
17344 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17346 IF (AMFSP2.LT.-TINY3) THEN
17347 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17348 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17349 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
17350 & I2,') with negative mass^2',/,1X,5E12.4)
17353 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17354 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17355 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17357 1003 FORMAT(1X,'HADRIN: warning! final state particle',
17358 & ' (id = ',I2,') with inconsistent mass',/,1X,
17361 IF (KCORR.GT.2) GOTO 9999
17362 IMCORR(KCORR) = NFSP
17365 * dump final state particles for energy-momentum cons. check
17366 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17367 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17370 * transform momenta on mass shell in case of inconsistencies in
17372 IF (KCORR.GT.0) THEN
17373 IF (KCORR.EQ.2) THEN
17377 IF (IMCORR(1).EQ.1) THEN
17385 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17386 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17387 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17388 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17390 P1IN(K) = PFSP(K,I1)
17391 P2IN(K) = PFSP(K,I2)
17393 XM1 = AAM(IDFSP(I1))
17394 XM2 = AAM(IDFSP(I2))
17395 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17396 IF (IREJ1.GT.0) THEN
17397 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17401 PFSP(K,I1) = P1OUT(K)
17402 PFSP(K,I2) = P2OUT(K)
17404 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17405 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
17406 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17407 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
17408 * dump final state particles for energy-momentum cons. check
17409 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17410 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17411 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17412 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17415 * check energy-momentum conservation
17417 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17418 IF (IREJ1.NE.0) GOTO 9999
17432 *$ CREATE DT_HADCOL.FOR
17435 *===hadcol=============================================================*
17437 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17439 ************************************************************************
17440 * Interface to the HADRIN-routines for inelastic and elastic *
17441 * scattering. This subroutine samples hadron-nucleus interactions *
17442 * below DPM-threshold. *
17443 * IDPROJ BAMJET-index of projectile hadron *
17444 * PPN projectile momentum in target rest frame *
17445 * IDXTAR DTEVT1-index of target nucleon undergoing *
17446 * interaction with projectile hadron *
17447 * This subroutine replaces HADHAD. *
17448 * This version dated 5.5.95 is written by S. Roesler *
17449 ************************************************************************
17451 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17453 PARAMETER ( LINP = 10 ,
17456 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17461 PARAMETER (NMXHKK=200000)
17462 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17463 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17464 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17465 * extended event history
17466 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17467 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17469 * nuclear potential
17471 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17472 & EBINDP(2),EBINDN(2),EPOT(2,210),
17473 & ETACOU(2),ICOUL,LFERMI
17474 * interface HADRIN-DPM
17475 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17476 * parameter for intranuclear cascade
17478 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17479 * final state after inc step
17480 PARAMETER (MAXFSP=10)
17481 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17482 * particle properties (BAMJET index convention)
17484 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17485 & IICH(210),IIBAR(210),K1(210),K2(210)
17487 DIMENSION PPROJ(5),PNUC(5)
17489 DATA LSTART /.TRUE./
17496 **sr 6/9/01 commented
17497 C TAUFOR = TAUFOR/2.0D0
17501 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
17502 WRITE(LOUT,1001) TAUFOR
17503 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
17508 IDNUC = IDBAM(IDXTAR)
17509 IDNUC1 = IDT_MCHAD(IDNUC)
17510 IDPRO1 = IDT_MCHAD(IDPROJ)
17512 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17516 C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17517 C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17519 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17520 SIGIN = SIGTOT-SIGEL
17521 C SIGTOT = SIGIN+SIGEL
17524 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17530 PPROJ(5) = AAM(IDPROJ)
17531 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17533 PNUC(K) = PHKK(K,IDXTAR)
17539 IF (ILOOP.GT.100) GOTO 9999
17541 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17542 IF (IREJ1.EQ.1) GOTO 9999
17544 IF (IREJ1.GT.1) THEN
17545 * no interaction possible
17546 * require Pauli blocking
17547 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17548 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17549 IF ((IIBAR(IDPROJ).NE.1).AND.
17550 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
17551 * store incoming particle as final state particle
17552 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17553 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17556 * require Pauli blocking for final state nucleons
17558 IF ((IDFSP(I).EQ.1).AND.
17559 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
17560 IF ((IDFSP(I).EQ.8).AND.
17561 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
17562 IF ((IIBAR(IDFSP(I)).NE.1).AND.
17563 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17565 * store final state particles
17568 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17569 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17570 IDHAD = IDT_IPDGHA(IDFSP(I))
17571 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17572 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17574 IF (I.EQ.1) NPOINT(4) = NHKK
17575 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17576 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17577 VHKK(3,NHKK) = VHKK(3,IDXTAR)
17578 VHKK(4,NHKK) = VHKK(4,IDXTAR)
17579 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17580 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17581 WHKK(3,NHKK) = WHKK(3,1)
17582 WHKK(4,NHKK) = WHKK(4,1)
17594 *$ CREATE DT_GETEMU.FOR
17597 *===getemu=============================================================*
17599 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17601 ************************************************************************
17602 * Sampling of emulsion component to be considered as target-nucleus. *
17603 * This version dated 6.5.95 is written by S. Roesler. *
17604 ************************************************************************
17606 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17608 PARAMETER ( LINP = 10 ,
17611 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17613 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17614 * emulsion treatment
17615 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17617 * Glauber formalism: flags and parameters for statistics
17620 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17622 IF (MODE.EQ.0) THEN
17624 RR = DT_RNDM(SUMFRA)
17627 DO 1 ICOMP=1,NCOMPO
17628 SUMFRA = SUMFRA+EMUFRA(ICOMP)
17629 IF (SUMFRA.GT.RR) THEN
17631 ITZ = IEMUCH(ICOMP)
17638 WRITE(LOUT,'(1X,A,E12.3)')
17639 & 'Warning! norm. failure within emulsion fractions',
17643 ELSEIF (MODE.EQ.1) THEN
17646 IDIFF = ABS(IT-IEMUMA(I))
17647 IF (IDIFF.LT.NDIFF) THEN
17656 * bypass for variable projectile/target/energy runs: the correct
17657 * Glauber data will be always loaded on kkmat=1
17658 IF (IOGLB.EQ.100) THEN
17665 *$ CREATE DT_NCLPOT.FOR
17668 *===nclpot=============================================================*
17670 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17672 ************************************************************************
17673 * Calculation of Coulomb and nuclear potential for a given configurat. *
17674 * IPZ, IP charge/mass number of proj. *
17675 * ITZ, IT charge/mass number of targ. *
17676 * AFERP,AFERT factors modifying proj./target pot. *
17677 * if =0, FERMOD is used *
17678 * MODE = 0 calculation of binding energy *
17679 * = 1 pre-calculated binding energy is used *
17680 * This version dated 16.11.95 is written by S. Roesler. *
17682 * Last change 28.12.2006 by S. Roesler. *
17683 ************************************************************************
17685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17687 PARAMETER ( LINP = 10 ,
17690 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17695 * particle properties (BAMJET index convention)
17697 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17698 & IICH(210),IIBAR(210),K1(210),K2(210)
17699 * nuclear potential
17701 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17702 & EBINDP(2),EBINDN(2),EPOT(2,210),
17703 & ETACOU(2),ICOUL,LFERMI
17705 DIMENSION IDXPOT(14)
17706 * ap an lam alam sig- sig+ sig0 tet0 tet- asig-
17707 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
17708 * asig0 asig+ atet0 atet+
17709 & 100, 101, 102, 103/
17712 DATA LSTART /.TRUE./
17714 IF (MODE.EQ.0) THEN
17726 IF (AFERP.LE.ZERO) FERMIP = FERMOD
17728 IF (AFERT.LE.ZERO) FERMIT = FERMOD
17730 * Fermi momenta and binding energy for projectile
17731 IF ((IP.GT.1).AND.LFERMI) THEN
17732 IF (MODE.EQ.0) THEN
17733 C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17734 C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17737 EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17738 & -DT_ENERGY(AIP,AIPZ))
17739 IF (AIP.LE.AIPZ) THEN
17740 EBINDN(1) = EBINDP(1)
17741 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17743 EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17744 & +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17747 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17748 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17753 * effective nuclear potential for projectile
17754 C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17755 C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17756 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17757 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17759 * Fermi momenta and binding energy for target
17760 IF ((IT.GT.1).AND.LFERMI) THEN
17761 IF (MODE.EQ.0) THEN
17762 C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17763 C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17767 EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17768 & -DT_ENERGY(AIT,AITZ))
17770 IF (AIT.LE.AITZ) THEN
17771 EBINDN(2) = EBINDP(2)
17772 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17775 EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17776 & +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17780 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17781 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17786 * effective nuclear potential for target
17787 C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17788 C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17789 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17790 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17793 EPOT(1,IDXPOT(I)) = EPOT(1,8)
17794 EPOT(2,IDXPOT(I)) = EPOT(2,8)
17800 IF (ICOUL.EQ.1) THEN
17802 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17804 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17808 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17809 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17810 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17812 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
17813 & ,' effects',/,12X,'---------------------------',
17814 & '----------------',/,/,38X,'projectile',
17815 & ' target',/,/,1X,'Mass number / charge',
17816 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
17817 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
17818 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
17819 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
17820 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
17821 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
17828 *$ CREATE DT_RESNCL.FOR
17831 *===resncl=============================================================*
17833 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17835 ************************************************************************
17836 * Treatment of residual nuclei and nuclear effects. *
17837 * MODE = 1 initializations *
17838 * = 2 treatment of final state *
17839 * This version dated 16.11.95 is written by S. Roesler. *
17841 * Last change 05.01.2007 by S. Roesler. *
17842 ************************************************************************
17844 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17846 PARAMETER ( LINP = 10 ,
17849 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17850 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17851 & ONETHI=ONE/THREE)
17852 PARAMETER (AMUAMU = 0.93149432D0,
17855 PARAMETER ( EMVGEV = 1.0 D-03 )
17856 PARAMETER ( AMUGEV = 0.93149432 D+00 )
17857 PARAMETER ( AMPRTN = 0.93827231 D+00 )
17858 PARAMETER ( AMNTRN = 0.93956563 D+00 )
17859 PARAMETER ( AMELCT = 0.51099906 D-03 )
17860 PARAMETER ( HLFHLF = 0.5D+00 )
17861 PARAMETER ( FERTHO = 14.33 D-09 )
17862 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17863 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17864 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17867 PARAMETER (NMXHKK=200000)
17868 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17869 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17870 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17871 * extended event history
17872 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17873 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17875 * particle properties (BAMJET index convention)
17877 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17878 & IICH(210),IIBAR(210),K1(210),K2(210)
17879 * flags for input different options
17880 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17881 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17882 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17883 * nuclear potential
17885 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17886 & EBINDP(2),EBINDN(2),EPOT(2,210),
17887 & ETACOU(2),ICOUL,LFERMI
17888 * properties of interacting particles
17889 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17890 * properties of photon/lepton projectiles
17891 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17892 * Lorentz-parameters of the current interaction
17893 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17894 & UMO,PPCM,EPROJ,PPROJ
17895 * treatment of residual nuclei: wounded nucleons
17896 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17897 * treatment of residual nuclei: 4-momenta
17898 LOGICAL LRCLPR,LRCLTA
17899 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17900 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17902 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17903 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17904 & IDXCOR(15000),IDXOTH(NMXHKK)
17908 *------- initializations
17911 * initialize arrays for residual nuclei
17926 * correction of projectile 4-momentum for effective target pot.
17927 * and Coulomb-energy (in case of hadron-nucleus interaction only)
17928 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17931 * positively charged hadron - check energy for Coloumb pot.
17932 IF (IICH(IJPROJ).EQ.1) THEN
17933 THRESH = ETACOU(2)+AAM(IJPROJ)
17934 IF (EPNI.LE.THRESH) THEN
17936 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
17937 & ' below Coulomb threshold - event rejected',/)
17941 * negatively charged hadron - increase energy by Coulomb energy
17942 ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17943 EPNI = EPNI+ETACOU(2)
17945 IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
17946 * Effective target potential
17947 *sr 6.6. binding energy only (to avoid negative exc. energies)
17948 C EPNI = EPNI+EPOT(2,IJPROJ)
17950 IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17951 & EBIPOT = EBINDN(2)
17952 EPNI = EPNI+ABS(EBIPOT)
17953 * re-initialization of DTLTRA
17956 CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17960 * projectile in n-n cms
17961 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17962 PMASS1 = AAM(IJPROJ)
17964 C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17965 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17967 PM1 = SIGN(PMASS1**2,PMASS1)
17968 PM2 = SIGN(PMASS2**2,PMASS2)
17969 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17971 IF (PMASS1.GT.ZERO) THEN
17972 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17973 & *(PINIPR(4)+PINIPR(5)))
17975 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17979 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17980 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17981 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17983 PMASS2 = AAM(IJTARG)
17984 PM1 = SIGN(PMASS1**2,PMASS1)
17985 PM2 = SIGN(PMASS2**2,PMASS2)
17986 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
17988 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
17989 & *(PINITA(4)+PINITA(5)))
17992 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17993 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17994 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
17997 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17998 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18001 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
18002 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18007 *------- treatment of final state
18011 IF (NLOOP.GT.1) SCPOT = 0.10D0
18012 C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18024 DO 900 I=NPOINT(4),NHKK
18026 IF (ISTHKK(I).EQ.1) THEN
18027 IF (IDBAM(I).EQ.7) GOTO 900
18030 * particle moving into forward direction
18031 IF (PHKK(3,I).GE.ZERO) THEN
18032 * most likely to be effected by projectile potential
18034 * there is no projectile nucleus, try target
18035 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18037 IF (IP.GT.1) IOTHER = 1
18038 * there is no target nucleus --> skip
18039 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18041 * particle moving into backward direction
18043 * most likely to be effected by target potential
18045 * there is no target nucleus, try projectile
18046 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18048 IF (IT.GT.1) IOTHER = 1
18049 * there is no projectile nucleus --> skip
18050 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18054 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18055 * =1: particle is not in overlap-region AND is inside target (2)
18056 * =2: particle is not in overlap-region AND is inside projectile (1)
18057 * flag particles which are inside the nucleus ipot but not in its
18059 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18060 IF (IDBAM(I).NE.0) THEN
18061 * baryons: keep all nucleons and all others where flag is set
18062 IF (IIBAR(IDBAM(I)).NE.0) THEN
18063 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18066 PMOMB(NOB) = PHKK(3,I)
18067 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
18068 & +1000000*IOTHER+I,IFLG)
18070 * mesons: keep only those mesons where flag is set
18072 IF (IFLG.GT.0) THEN
18074 PMOMM(NOM) = PHKK(3,I)
18075 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
18082 * sort particles in the arrays according to increasing long. momentum
18083 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18084 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18086 * shuffle indices into one and the same array according to the later
18087 * sequence of correction
18091 IF (PMOMB(I).GT.ZERO) GOTO 911
18093 IDXCOR(NCOR) = IDXB(I)
18099 IF (PMOMB(I).LT.ZERO) GOTO 913
18101 IDXCOR(NCOR) = IDXB(I)
18106 IF (PMOMB(I).GT.ZERO) THEN
18108 IDXCOR(NCOR) = IDXB(I)
18116 IDXCOR(NCOR) = IDXB(I)
18120 IF (PMOMM(I).GT.ZERO) GOTO 926
18122 IDXCOR(NCOR) = IDXM(I)
18127 IF (PMOMM(I).LT.ZERO) GOTO 928
18129 IDXCOR(NCOR) = IDXM(I)
18133 C IF (NEVHKK.EQ.484) THEN
18134 C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18135 C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
18136 C WRITE(LOUT,9001) NOB,NOM,NCOR
18137 C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18138 C WRITE(LOUT,'(/,A)') ' baryons '
18140 CC J = IABS(IDXB(I))
18141 CC INDEX = J-IABS(J/10000000)*10000000
18142 C IPOT = IABS(IDXB(I))/10000000
18143 C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18144 C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18145 C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18147 C WRITE(LOUT,'(/,A)') ' mesons '
18149 CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18150 C IPOT = IABS(IDXM(I))/10000000
18151 C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18152 C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18153 C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18155 C 9002 FORMAT(1X,4I14,E14.5)
18156 C WRITE(LOUT,'(/,A)') ' all '
18158 CC J = IABS(IDXCOR(I))
18159 CC INDEX = J-IABS(J/10000000)*10000000
18160 CC IPOT = IABS(IDXCOR(I))/10000000
18161 C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18162 C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18163 C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18165 C 9003 FORMAT(1X,4I14)
18169 IPOT = IABS(IDXCOR(ICOR))/10000000
18170 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18171 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18176 * reduction of particle momentum by corresponding nuclear potential
18177 * (this applies only if Fermi-momenta are requested)
18181 * Lorentz-transformation into the rest system of the selected nucleus
18183 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18184 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18185 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18186 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18190 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18191 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18192 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18193 IF (IOULEV(3).GT.0)
18194 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18195 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
18196 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18197 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
18205 * the correction for nuclear potential effects is applied to as many
18206 * p/n as many nucleons were wounded; the momenta of other final state
18207 * particles are corrected only if they materialize inside the corresp.
18208 * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18209 * = 3 part. outside proj. and targ., >=10 in overlapping region)
18210 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18211 IF (IPOT.EQ.1) THEN
18212 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18213 * this is most likely a wounded nucleon
18215 C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18216 C & +(VHKK(2,IPW(JPW))/FM2MM)**2
18217 C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
18218 C RAD = RNUCLE*DBLE(IP)**ONETHI
18219 C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18220 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18222 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18226 * correct only if part. was materialized inside nucleus
18227 * and if it is ouside the overlapping region
18228 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18229 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18233 ELSEIF (IPOT.EQ.2) THEN
18234 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18235 * this is most likely a wounded nucleon
18237 C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18238 C & +(VHKK(2,ITW(JTW))/FM2MM)**2
18239 C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
18240 C RAD = RNUCLE*DBLE(IT)**ONETHI
18241 C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18242 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18244 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18248 * correct only if part. was materialized inside nucleus
18249 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18250 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18256 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18257 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18262 IF (NLOOP.EQ.1) THEN
18263 * Coulomb energy correction:
18264 * the treatment of Coulomb potential correction is similar to the
18265 * one for nuclear potential
18266 IF (IDSEC.EQ.1) THEN
18267 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18269 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18272 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18275 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18277 IF (IICH(IDSEC).EQ.1) THEN
18278 * pos. particles: check if they are able to escape Coulomb potential
18279 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18280 ISTHKK(I) = 14+IPOT
18281 IF (ISTHKK(I).EQ.15) THEN
18283 PHKK(K,I) = PSEC0(K)
18284 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18286 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18287 IF (IDSEC.EQ.1) NPCW = NPCW-1
18288 ELSEIF (ISTHKK(I).EQ.16) THEN
18290 PHKK(K,I) = PSEC0(K)
18291 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18293 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18294 IF (IDSEC.EQ.1) NTCW = NTCW-1
18298 ELSEIF (IICH(IDSEC).EQ.-1) THEN
18299 * neg. particles: decrease energy by Coulomb-potential
18300 PSEC(4) = PSEC(4)-ETACOU(IPOT)
18307 IF (PSEC(4).LT.AMSEC) THEN
18308 IF (IOULEV(6).GT.0)
18309 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18310 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18311 & ' is not allowed to escape nucleus',/,
18312 & 8X,'id : ',I3,' reduced energy: ',E15.4,
18314 ISTHKK(I) = 14+IPOT
18315 IF (ISTHKK(I).EQ.15) THEN
18317 PHKK(K,I) = PSEC0(K)
18318 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18320 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18321 IF (IDSEC.EQ.1) NPCW = NPCW-1
18322 ELSEIF (ISTHKK(I).EQ.16) THEN
18324 PHKK(K,I) = PSEC0(K)
18325 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18327 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18328 IF (IDSEC.EQ.1) NTCW = NTCW-1
18333 IF (JPMOD.EQ.1) THEN
18334 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18335 * 4-momentum after correction for nuclear potential
18337 PSEC(K) = PSEC(K)*PSECN/PSECO
18340 * store recoil momentum from particles escaping the nuclear potentials
18342 IF (IPOT.EQ.1) THEN
18343 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18344 ELSEIF (IPOT.EQ.2) THEN
18345 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18349 * transform momentum back into n-n cms
18351 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18352 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18360 PFSP(K) = PFSP(K)+PHKK(K,I)
18365 DO 33 I=NPOINT(4),NHKK
18366 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18367 PFSP(1) = PFSP(1)+PHKK(1,I)
18368 PFSP(2) = PFSP(2)+PHKK(2,I)
18369 PFSP(3) = PFSP(3)+PHKK(3,I)
18370 PFSP(4) = PFSP(4)+PHKK(4,I)
18375 PRCLPR(K) = TRCLPR(K)
18376 PRCLTA(K) = TRCLTA(K)
18379 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18380 * hadron-nucleus interactions: get residual momentum from energy-
18381 * momentum conservation
18384 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18387 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18388 * accumulated recoil momenta of particles leaving the spectators
18389 * transform accumulated recoil momenta of residual nuclei into
18393 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18396 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18397 C IF (IP.GT.1) THEN
18398 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18399 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18402 PRCLTA(3) = PRCLTA(3)+PINITA(3)
18403 PRCLTA(4) = PRCLTA(4)+PINITA(4)
18407 * check momenta of residual nuclei
18409 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18411 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18413 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18415 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18417 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18418 **sr 19.12. changed to avoid output when used with phojet
18421 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18422 C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18423 C & CALL DT_EVTOUT(4)
18424 IF (IREJ1.GT.0) RETURN
18430 *$ CREATE DT_SCN4BA.FOR
18433 *===scn4ba=============================================================*
18435 SUBROUTINE DT_SCN4BA
18437 ************************************************************************
18438 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
18439 * This version dated 12.12.95 is written by S. Roesler. *
18440 ************************************************************************
18442 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18444 PARAMETER ( LINP = 10 ,
18447 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18451 PARAMETER (NMXHKK=200000)
18452 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18453 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18454 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18455 * extended event history
18456 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18457 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18459 * particle properties (BAMJET index convention)
18461 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18462 & IICH(210),IIBAR(210),K1(210),K2(210)
18463 * properties of interacting particles
18464 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18465 * nuclear potential
18467 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18468 & EBINDP(2),EBINDN(2),EPOT(2,210),
18469 & ETACOU(2),ICOUL,LFERMI
18470 * treatment of residual nuclei: wounded nucleons
18471 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18472 * treatment of residual nuclei: 4-momenta
18473 LOGICAL LRCLPR,LRCLTA
18474 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18475 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18477 DIMENSION PLAB(2,5),PCMS(4)
18481 * get number of wounded nucleons
18498 * projectile nucleons wounded in primary interaction and in fzc
18499 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18503 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18504 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
18505 C IF (IP.GT.1) THEN
18507 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18510 * target nucleons wounded in primary interaction and in fzc
18511 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18515 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18516 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
18519 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18522 ELSEIF (ISTHKK(I).EQ.13) THEN
18524 ELSEIF (ISTHKK(I).EQ.14) THEN
18529 DO 11 I=NPOINT(4),NHKK
18530 * baryons which are unable to escape the nuclear potential of proj.
18531 IF (ISTHKK(I).EQ.15) THEN
18534 IF (IIBAR(IDBAM(I)).NE.0) THEN
18536 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18539 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18541 * baryons which are unable to escape the nuclear potential of targ.
18542 ELSEIF (ISTHKK(I).EQ.16) THEN
18545 IF (IIBAR(IDBAM(I)).NE.0) THEN
18547 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18550 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18555 * residual nuclei so far
18559 * ckeck for "residual nuclei" consisting of one nucleon only
18560 * treat it as final state particle
18561 IF (IRESP.EQ.1) THEN
18563 IST = ISTHKK(ISGLPR)
18564 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18565 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18566 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18567 IF (IST.EQ.13) THEN
18568 ISTHKK(ISGLPR) = 11
18572 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18573 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18574 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18575 NOBAM(NHKK) = NOBAM(ISGLPR)
18576 JDAHKK(1,ISGLPR) = NHKK
18578 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18581 IF (IREST.EQ.1) THEN
18583 IST = ISTHKK(ISGLTA)
18584 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18585 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18586 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18587 IF (IST.EQ.14) THEN
18588 ISTHKK(ISGLTA) = 12
18592 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18593 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18594 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18595 NOBAM(NHKK) = NOBAM(ISGLTA)
18596 JDAHKK(1,ISGLTA) = NHKK
18598 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18602 * get nuclear potential corresp. to the residual nucleus
18607 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18609 * baryons unable to escape the nuclear potential are treated as
18610 * excited nucleons (ISTHKK=15,16)
18611 DO 3 I=NPOINT(4),NHKK
18612 IF (ISTHKK(I).EQ.1) THEN
18614 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18615 * final state n and p not being outside of both nuclei are considered
18618 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
18619 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
18620 * Lorentz-trsf. into proj. rest sys. for those being inside proj.
18621 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18622 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18624 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18625 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18626 & (PLAB(1,4)+PLABT) ))
18627 EKIN = PLAB(1,4)-PLAB(1,5)
18628 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18629 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18631 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
18632 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
18633 * Lorentz-trsf. into targ. rest sys. for those being inside targ.
18634 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18635 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18637 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18638 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18639 & (PLAB(2,4)+PLABT) ))
18640 EKIN = PLAB(2,4)-PLAB(2,5)
18641 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18642 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18644 IF (PHKK(3,I).GE.ZERO) THEN
18646 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18649 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18651 IF (ISTHKK(I).NE.1) THEN
18654 PHKK(K,I) = PLAB(J,K)
18656 IF (ISTHKK(I).EQ.15) THEN
18658 IF (ID.EQ.1) NPCW = NPCW-1
18660 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18662 ELSEIF (ISTHKK(I).EQ.16) THEN
18664 IF (ID.EQ.1) NTCW = NTCW-1
18666 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18674 * again: get nuclear potential corresp. to the residual nucleus
18679 c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18680 cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18681 c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18683 c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18684 cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18685 c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18687 C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18688 C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18689 C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18690 C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18691 AFERP = FERMOD+0.1D0
18692 AFERT = FERMOD+0.1D0
18694 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18699 *$ CREATE DT_FICONF.FOR
18702 *===ficonf=============================================================*
18704 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18706 ************************************************************************
18707 * Treatment of FInal CONFiguration including evaporation, fission and *
18708 * Fermi-break-up (for light nuclei only). *
18709 * Adopted from the original routine FINALE and extended to residual *
18710 * projectile nuclei. *
18711 * This version dated 12.12.95 is written by S. Roesler. *
18713 * Last change 27.12.2006 by S. Roesler. *
18714 ************************************************************************
18716 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18718 PARAMETER ( LINP = 10 ,
18721 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18722 PARAMETER (ANGLGB=5.0D-16)
18723 PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18726 PARAMETER (NMXHKK=200000)
18727 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18728 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18729 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18730 * extended event history
18731 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18732 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18734 * rejection counter
18735 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18736 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18737 & IREXCI(3),IRDIFF(2),IRINC
18738 * central particle production, impact parameter biasing
18739 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18740 * particle properties (BAMJET index convention)
18742 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18743 & IICH(210),IIBAR(210),K1(210),K2(210)
18744 * treatment of residual nuclei: 4-momenta
18745 LOGICAL LRCLPR,LRCLTA
18746 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18747 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18748 * treatment of residual nuclei: properties of residual nuclei
18749 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18750 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18751 & NTOTFI(2),NPROFI(2)
18752 * statistics: residual nuclei
18753 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18754 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18755 & NINCST(2,4),NINCEV(2),
18756 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18757 & NRESPB(2),NRESCH(2),NRESEV(4),
18758 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18760 * flags for input different options
18761 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18762 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18763 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18764 * (original name: FINUC)
18765 PARAMETER (MXP=999)
18766 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
18767 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18768 & TKI (MXP), PLR (MXP), WEI (MXP),
18769 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18771 * (original name: RESNUC)
18772 LOGICAL LRNFSS, LFRAGM
18773 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18774 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18775 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
18776 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
18777 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18778 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18779 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18780 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18782 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
18783 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
18784 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18785 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18786 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18787 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18788 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
18789 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
18790 * (original name: PAREVT)
18791 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18792 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18793 PARAMETER ( NALLWP = 39 )
18794 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18795 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18796 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18797 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18799 COMMON /DTEVNO/ NEVENT,ICASCA
18801 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18802 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18803 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18805 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18807 DATA EXC,NEXC /520*ZERO,520*0/
18808 DATA EXPNUC /4.0D-3,4.0D-3/
18814 * skip residual nucleus treatment if not requested or in case
18815 * of central collisions
18816 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18843 * number of final state particles
18844 IF (ABS(ISTHKK(I)).EQ.1) THEN
18849 * properties of remaining nucleon configurations
18851 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18852 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18854 IF (MO1(KF).EQ.0) MO1(KF) = I
18856 * position of residual nucleus = average position of nucleons
18858 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18859 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18861 * total number of particles contributing to each residual nucleus
18862 NTOT(KF) = NTOT(KF)+1
18865 * total charge of residual nuclei
18866 NQ(KF) = NQ(KF)+IICH(IDTMP)
18867 * number of protons
18868 IF (IDHKK(I).EQ.2212) THEN
18869 NPRO(KF) = NPRO(KF)+1
18870 * number of neutrons
18871 ELSEIF (IDHKK(I).EQ.2112) THEN
18874 * number of baryons other than n, p
18875 IF (IIBAR(IDTMP).EQ.1) THEN
18877 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18879 * any other mesons (status set to 1)
18880 C WRITE(LOUT,1002) KF,IDTMP
18881 C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
18882 C & ' containing meson ',I4,', status set to 1')
18885 IDXTMP = IDXPAR(KF)
18886 NTOT(KF) = NTOT(KF)-1
18890 IDXPAR(KF) = IDXTMP
18894 * reject elastic events (def: one final state particle = projectile)
18895 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18896 IREXCI(3) = IREXCI(3)+1
18901 * check if one nucleus disappeared..
18902 C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18904 C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18907 C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18909 C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18918 * get the average of the nucleon positions
18919 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18920 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18921 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18922 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18924 * mass number and charge of residual nuclei
18925 AIF(I) = DBLE(NTOT(I))
18926 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18927 IF (NTOT(I).GT.1) THEN
18928 * masses of residual nuclei in ground state
18929 AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18930 * masses of residual nuclei
18931 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18932 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18933 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18935 * M_res^2 < 0 : configuration not allowed
18937 * a) re-calculate E_exc with scaled nuclear potential
18938 * (conditional jump to label 9998)
18939 * b) or reject event if N_loop(max) is exceeded
18940 * (conditional jump to label 9999)
18942 IF (AMRCL(I).LE.ZERO) THEN
18943 IF (IOULEV(3).GT.0)
18944 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18946 1000 FORMAT(1X,'warning! negative excitation energy',/,
18950 IF (NLOOP.LE.500) THEN
18953 IREXCI(2) = IREXCI(2)+1
18957 * 0 < M_res < M_res0 : mass below ground-state mass
18959 * a) we had residual nuclei with mass N_tot and reasonable E_exc
18960 * before- assign average E_exc of those configurations to this
18961 * one ( Nexc(i,N_tot) > 0 )
18962 * b) or (and this applies always if run in transport codes) go up
18963 * one mass number and
18964 * i) if mass now larger than proj/targ mass or if run in
18965 * transport codes assign average E_exc per wounded nucleon
18966 * x number of wounded nucleons (Inuc-Ntot)
18967 * ii) or assign average E_exc of those configurations to this
18968 * one ( Nexc(i,m) > 0 )
18970 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18972 M = MIN(NTOT(I),260)
18973 IF (NEXC(I,M).GT.0) THEN
18974 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18978 **sr corrected 27.12.06
18979 * IF (M.GE.INUC(I)) THEN
18980 * AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18981 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18982 IF ( INUC (I) .GT. NTOT (I) ) THEN
18983 AMRCL(I) = AMRCL0(I)
18984 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
18986 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
18990 IF (NEXC(I,M).GT.0) THEN
18991 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18997 EEXC(I) = AMRCL(I)-AMRCL0(I)
19000 * M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
19002 * a) re-calculate E_exc with scaled nuclear potential
19003 * (conditional jump to label 9998)
19004 * b) or reject event if N_loop(max) is exceeded
19005 * (conditional jump to label 9999)
19008 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19009 IF (IOULEV(3).GT.0)
19010 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19011 1004 FORMAT(1X,'warning! too high excitation energy',/,
19012 & I4,1P,2E15.4,3I5)
19015 IF (NLOOP.LE.500) THEN
19018 IREXCI(2) = IREXCI(2)+1
19022 * Otherwise (reasonable E_exc) :
19023 * E_exc = M_res - M_res0
19024 * in addition: calculate and save E_exc per wounded nucleon as
19025 * well as E_exc in <E_exc> counter
19028 * excitation energies of residual nuclei
19029 EEXC(I) = AMRCL(I)-AMRCL0(I)
19030 **sr 27.12.06 new excitation energy correction by A.F.
19032 * all parts with Ilcopt<3 commented since not used
19034 * still to be done/decided:
19035 * Increase Icor and put back both residual nuclei on mass shell
19036 * with the exciting correction further below.
19037 * For the moment the modification in the excitation energy is simply
19038 * corrected by scaling the energy of the residual nucleus.
19043 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19044 IF ( ILCOPT .LE. 2 ) THEN
19045 C* Patch for Fermi momentum reduction correlated with impact parameter:
19046 C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19047 C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19048 C AKPRHO = ONE - DLKPRH
19049 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19050 C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
19052 C* REDORI = 0.75D+00
19054 C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19057 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19058 * Take out roughly one/half of the skin:
19059 RDCORE = RDCORE - 0.5D+00
19061 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19062 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19063 FRCFLL = ONE - PRSKIN
19064 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19065 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19067 IF ( NNCHIT .GT. 0 ) THEN
19068 C IF ( ILCOPT .EQ. 1 ) THEN
19069 C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19070 C DO 1220 NCH = 1, 10
19071 C ETAETA = ( ONE - SKINRH**INUC(I)
19072 C & - DBLE(INUC(I))* ( ONE - FRCFLL )
19073 C & * ( ONE - SKINRH ) )
19074 C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
19075 C & * ( ONE - FRCFLL) * SKINRH )
19076 C SKINRH = SKINRH * ( ONE + ETAETA )
19078 C PRSKIN = SKINRH**(NNCHIT-1)
19079 C ELSE IF ( ILCOPT .EQ. 2 ) THEN
19080 C PRSKIN = ONE - FRCFLL
19083 DO 1230 NCH = 1, NNCHIT
19084 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19085 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19086 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19088 PRFRMI = ( ONE - 2.D+00 * DLKPRH
19089 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19091 REDCTN = REDCTN + PRFRMI**2
19093 REDCTN = REDCTN / DBLE (NNCHIT)
19097 EEXC (I) = EEXC (I) * REDCTN / REDORI
19098 AMRCL (I) = AMRCL0 (I) + EEXC (I)
19099 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19102 IF (ICASCA.EQ.0) THEN
19103 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19104 M = MIN(NTOT(I),260)
19105 EXC(I,M) = EXC(I,M)+EEXC(I)
19106 NEXC(I,M) = NEXC(I,M)+1
19109 ELSEIF (NTOT(I).EQ.1) THEN
19111 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
19121 PRCLPR(5) = AMRCL(1)
19122 PRCLTA(5) = AMRCL(2)
19124 IF (ICOR.GT.0) THEN
19125 IF (INORCL.EQ.0) THEN
19126 * one or both residual nuclei consist of one nucleon only, transform
19127 * this nucleon on mass shell
19129 P1IN(K) = PRCL(1,K)
19130 P2IN(K) = PRCL(2,K)
19134 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19135 IF (IREJ1.GT.0) THEN
19136 WRITE(LOUT,*) 'ficonf-mashel rejection'
19140 PRCL(1,K) = P1OUT(K)
19141 PRCL(2,K) = P2OUT(K)
19142 PRCLPR(K) = P1OUT(K)
19143 PRCLTA(K) = P2OUT(K)
19145 PRCLPR(5) = AMRCL(1)
19146 PRCLTA(5) = AMRCL(2)
19148 IF (IOULEV(3).GT.0)
19149 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19150 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19151 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19152 & AMRCL(2),AMRCL(2)-AMRCL0(2)
19153 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
19154 & ' correction',/,11X,'at event',I8,
19155 & ', nucleon config. 1:',2I4,' 2:',2I4,
19157 IF (NLOOP.LE.500) THEN
19160 IREXCI(1) = IREXCI(1)+1
19166 C IF (NRESEV(1).NE.NEVHKK) THEN
19167 C NRESEV(1) = NEVHKK
19168 C NRESEV(2) = NRESEV(2)+1
19170 NRESEV(2) = NRESEV(2)+1
19172 EXCDPM(I) = EXCDPM(I)+EEXC(I)
19173 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19174 NRESTO(I) = NRESTO(I)+NTOT(I)
19175 NRESPR(I) = NRESPR(I)+NPRO(I)
19176 NRESNU(I) = NRESNU(I)+NN(I)
19177 NRESBA(I) = NRESBA(I)+NH(I)
19178 NRESPB(I) = NRESPB(I)+NHPOS(I)
19179 NRESCH(I) = NRESCH(I)+NQ(I)
19185 * initialize evaporation counter
19187 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19188 & (EEXC(I).GT.ZERO)) THEN
19189 * put residual nuclei into DTEVT1
19191 JMASS = INT( AIF(I))
19192 JCHAR = INT(AIZF(I))
19193 * the following patch is required to transmit the correct excitation
19195 IF (ITRSPT.EQ.1) THEN
19196 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19197 & (IOULEV(3).GT.0))
19199 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19200 & AMRCL(I),AMRCL0(I),EEXC(I)
19202 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19204 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19206 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19209 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19210 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19215 VHKK(J,NHKK) = VRCL(I,J)
19216 WHKK(J,NHKK) = WRCL(I,J)
19218 * interface to evaporation module - fill final residual nucleus into
19220 * fill resnuc only if code is not used as event generator in Fluka
19221 IF (ITRSPT.NE.1) THEN
19225 IBRES = NPRO(I)+NN(I)+NH(I)
19226 ICRES = NPRO(I)+NHPOS(I)
19229 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
19230 * ground state mass of the residual nucleus (should be equal to AM0T)
19232 AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19235 * kinetic energy of residual nucleus
19236 TVRECL = PRCL(I,4)-AMRCL(I)
19237 * excitation energy of residual nucleus
19240 PTRES = SQRT(ABS(TVRECL*(TVRECL+
19241 & 2.0D0*(AMMRES+TVCMS))))
19242 IF (PTOLD.LT.ANGLGB) THEN
19243 CALL DT_RACO(PXRES,PYRES,PZRES)
19246 PXRES = PXRES*PTRES/PTOLD
19247 PYRES = PYRES*PTRES/PTOLD
19248 PZRES = PZRES*PTRES/PTOLD
19249 * zero counter of secondaries from evaporation
19254 * put evaporated particles and residual nuclei to DTEVT1
19256 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19259 EXCEVA(I) = EXCEVA(I)+EXCITF
19266 C9998 IREXCI(1) = IREXCI(1)+1
19275 *$ CREATE DT_EVA2HE.FOR
19278 *====eva2he============================================================*
19280 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19282 ************************************************************************
19283 * Interface between common's of evaporation module (FKFINU,FKFHVY) *
19285 * MO DTEVT1-index of "mother" (residual) nucleus before evap. *
19286 * EEXCF exitation energy of residual nucleus after evaporation *
19287 * IRCL = 1 projectile residual nucleus *
19288 * = 2 target residual nucleus *
19289 * This version dated 19.04.95 is written by S. Roesler. *
19291 * Last change 27.12.2006 by S. Roesler. *
19292 ************************************************************************
19294 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19296 PARAMETER ( LINP = 10 ,
19299 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19302 PARAMETER (NMXHKK=200000)
19303 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19304 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19305 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19306 * Note: DTEVT2 - special use for heavy fragments !
19307 * (IDRES(I) = mass number, IDXRES(I) = charge)
19308 * extended event history
19309 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19310 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19312 * particle properties (BAMJET index convention)
19314 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19315 & IICH(210),IIBAR(210),K1(210),K2(210)
19316 * flags for input different options
19317 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19318 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19319 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19320 * statistics: residual nuclei
19321 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19322 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19323 & NINCST(2,4),NINCEV(2),
19324 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19325 & NRESPB(2),NRESCH(2),NRESEV(4),
19326 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19328 * treatment of residual nuclei: properties of residual nuclei
19329 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19330 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19331 & NTOTFI(2),NPROFI(2)
19332 * (original name: FINUC)
19333 PARAMETER (MXP=999)
19334 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
19335 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19336 & TKI (MXP), PLR (MXP), WEI (MXP),
19337 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19339 * (original name: FHEAVY,FHEAVC)
19340 PARAMETER ( MXHEAV = 100 )
19342 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19343 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19344 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19345 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
19346 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
19347 & IBHEAV ( 12 ) , NPHEAV
19348 COMMON /FKFHVC/ ANHEAV ( 12 )
19349 * (original name: RESNUC)
19350 LOGICAL LRNFSS, LFRAGM
19351 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19352 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19353 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19354 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
19355 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19356 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19357 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19358 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19361 DIMENSION IPTOKP(39)
19362 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19363 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19364 & 100, 101, 97, 102, 98, 103, 109, 115 /
19368 * skip if evaporation package is not included
19369 IF (.NOT.LEVAPO) RETURN
19372 IF (NRESEV(3).NE.NEVHKK) THEN
19374 NRESEV(4) = NRESEV(4)+1
19378 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19380 * mass number/charge of residual nucleus before evaporation
19384 * protons/neutrons/gammas
19389 ID = IPTOKP(KPART(I))
19390 IDPDG = IDT_IPDGHA(ID)
19391 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19392 & (2.0D0*MAX(TKI(I),TINY10))
19393 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19394 WRITE(LOUT,1000) ID,AM,AAM(ID)
19395 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
19396 & 'particle',I3,2E10.3)
19399 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19401 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19402 IBTOT = IBTOT-IIBAR(ID)
19403 IZTOT = IZTOT-IICH(ID)
19408 PX = CXHEAV(I)*PHEAVY(I)
19409 PY = CYHEAV(I)*PHEAVY(I)
19410 PZ = CZHEAV(I)*PHEAVY(I)
19412 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19413 & (2.0D0*MAX(TKHEAV(I),TINY10))
19415 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19416 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19418 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19419 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19420 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19423 IF (IBRES.GT.0) THEN
19424 * residual nucleus after evaporation
19426 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19431 NTOTFI(IRCL) = IBRES
19432 NPROFI(IRCL) = ICRES
19433 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19434 IBTOT = IBTOT-IBRES
19435 IZTOT = IZTOT-ICRES
19437 * count events with fission
19438 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19439 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19441 * energy-momentum conservation check
19442 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19443 C IF (IREJ.GT.0) THEN
19444 C CALL DT_EVTOUT(4)
19445 C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19447 * baryon-number/charge conservation check
19448 IF (IBTOT+IZTOT.NE.0) THEN
19449 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19450 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
19451 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
19457 *$ CREATE DT_EBIND.FOR
19460 *===ebind==============================================================*
19462 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19464 ************************************************************************
19465 * Binding energy for nuclei. *
19466 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
19468 * IZ atomic number *
19469 * This version dated 5.5.95 is updated by S. Roesler. *
19470 ************************************************************************
19472 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19474 PARAMETER ( LINP = 10 ,
19477 PARAMETER (ZERO=0.0D0)
19479 DATA A1, A2, A3, A4, A5
19480 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19482 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19483 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
19488 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19489 & -A4*(IA-2*IZ)**2/AA
19490 IF (MOD(IA,2).EQ.1) THEN
19492 ELSEIF (MOD(IZ,2).EQ.1) THEN
19497 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19502 **sr 30.6. routine replaced completely
19503 *$ CREATE DT_ENERGY.FOR
19506 *=== energy ===========================================================*
19508 DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19510 C INCLUDE '(DBLPRC)'
19512 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19514 * (original name: GLOBAL)
19515 PARAMETER ( KALGNM = 2 )
19516 PARAMETER ( ANGLGB = 5.0D-16 )
19517 PARAMETER ( ANGLSQ = 2.5D-31 )
19518 PARAMETER ( AXCSSV = 0.2D+16 )
19519 PARAMETER ( ANDRFL = 1.0D-38 )
19520 PARAMETER ( AVRFLW = 1.0D+38 )
19521 PARAMETER ( AINFNT = 1.0D+30 )
19522 PARAMETER ( AZRZRZ = 1.0D-30 )
19523 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19524 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19525 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19526 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19527 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
19528 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
19529 PARAMETER ( CSNNRM = 2.0D-15 )
19530 PARAMETER ( DMXTRN = 1.0D+08 )
19531 PARAMETER ( ZERZER = 0.D+00 )
19532 PARAMETER ( ONEONE = 1.D+00 )
19533 PARAMETER ( TWOTWO = 2.D+00 )
19534 PARAMETER ( THRTHR = 3.D+00 )
19535 PARAMETER ( FOUFOU = 4.D+00 )
19536 PARAMETER ( FIVFIV = 5.D+00 )
19537 PARAMETER ( SIXSIX = 6.D+00 )
19538 PARAMETER ( SEVSEV = 7.D+00 )
19539 PARAMETER ( EIGEIG = 8.D+00 )
19540 PARAMETER ( ANINEN = 9.D+00 )
19541 PARAMETER ( TENTEN = 10.D+00 )
19542 PARAMETER ( HLFHLF = 0.5D+00 )
19543 PARAMETER ( ONETHI = ONEONE / THRTHR )
19544 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19545 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19546 PARAMETER ( THRTWO = THRTHR / TWOTWO )
19547 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19548 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19549 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19550 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19551 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19552 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19553 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19554 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
19555 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
19556 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
19557 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
19558 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19559 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19560 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19561 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19562 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19563 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19564 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19565 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19566 PARAMETER ( CLIGHT = 2.99792458 D+10 )
19567 PARAMETER ( AVOGAD = 6.0221367 D+23 )
19568 PARAMETER ( BOLTZM = 1.380658 D-23 )
19569 PARAMETER ( AMELGR = 9.1093897 D-28 )
19570 PARAMETER ( PLCKBR = 1.05457266 D-27 )
19571 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19572 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19573 PARAMETER ( AMUGRM = 1.6605402 D-24 )
19574 PARAMETER ( AMMUMU = 0.113428913 D+00 )
19575 PARAMETER ( AMPRMU = 1.007276470 D+00 )
19576 PARAMETER ( AMNEMU = 1.008664904 D+00 )
19577 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19578 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19579 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19580 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19581 PARAMETER ( PLABRC = 0.197327053 D+00 )
19582 PARAMETER ( AMELCT = 0.51099906 D-03 )
19583 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19584 PARAMETER ( AMMUON = 0.105658389 D+00 )
19585 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19586 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19587 PARAMETER ( AMDEUT = 1.87561339 D+00 )
19588 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19590 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19591 PARAMETER ( BLTZMN = 8.617385 D-14 )
19592 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19593 PARAMETER ( GFOHB3 = 1.16639 D-05 )
19594 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19595 PARAMETER ( SIN2TW = 0.2319 D+00 )
19596 PARAMETER ( GEVMEV = 1.0 D+03 )
19597 PARAMETER ( EMVGEV = 1.0 D-03 )
19598 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
19599 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19600 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19601 LOGICAL LGBIAS, LGBANA
19602 COMMON /FKGLOB/ LGBIAS, LGBANA
19603 C INCLUDE '(DIMPAR)'
19605 PARAMETER ( MXXRGN = 5000 )
19606 PARAMETER ( MXXMDF = 82 )
19607 PARAMETER ( MXXMDE = 54 )
19608 PARAMETER ( MFSTCK = 1000 )
19609 PARAMETER ( MESTCK = 100 )
19610 PARAMETER ( NALLWP = 39 )
19611 PARAMETER ( NELEMX = 80 )
19612 PARAMETER ( MPDPDX = 8 )
19613 PARAMETER ( ICOMAX = 180 )
19614 PARAMETER ( NSTBIS = 304 )
19615 PARAMETER ( IDMAXP = 220 )
19616 PARAMETER ( IDMXDC = 640 )
19617 PARAMETER ( MKBMX1 = 1 )
19618 PARAMETER ( MKBMX2 = 1 )
19619 C INCLUDE '(IOUNIT)'
19621 PARAMETER ( LUNIN = 5 )
19622 PARAMETER ( LUNOUT = 6 )
19623 **sr 19.5. set error output-unit from 15 to 6
19624 PARAMETER ( LUNERR = 6 )
19625 PARAMETER ( LUNBER = 14 )
19626 PARAMETER ( LUNECH = 8 )
19627 PARAMETER ( LUNFLU = 13 )
19628 PARAMETER ( LUNGEO = 16 )
19629 PARAMETER ( LUNPMF = 12 )
19630 PARAMETER ( LUNRAN = 2 )
19631 PARAMETER ( LUNXSC = 9 )
19632 PARAMETER ( LUNDET = 17 )
19633 PARAMETER ( LUNRAY = 10 )
19634 PARAMETER ( LUNRDB = 1 )
19635 PARAMETER ( LUNPGO = 7 )
19636 PARAMETER ( LUNPGS = 4 )
19637 PARAMETER ( LUNSCR = 3 )
19639 *----------------------------------------------------------------------*
19641 * Revised version of the original routine from EVAP: *
19643 * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
19646 * Last change on 19-sep-95 by Alfredo Ferrari *
19648 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19649 * !!! It is supposed to be used with the updated atomic !!! *
19650 * !!! mass data file !!! *
19651 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19653 *----------------------------------------------------------------------*
19655 * Mass number below which "unknown" isotopes out of the Z-interval
19656 * reported in the mass tabulations are completely unstable and made
19657 * up by Z proton masses + N neutron masses:
19658 PARAMETER ( KAFREE = 4 )
19659 * Mass number below which "unknown" isotopes out of the Z-interval
19660 * reported in the mass tabulations are supposed to be particle unstable
19661 PARAMETER ( KAPUNS = 12 )
19662 * Minimum energy required for particle unstable isotopes
19663 PARAMETER ( DEPUNS = 0.5D+00 )
19665 * (original name: EVA0)
19666 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19667 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19668 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19669 * T (4,7), RMASS (297), ALPH (297), BET (297),
19670 * APRIME (250), IA (6), IZ (6)
19671 * (original name: ISOTOP)
19672 PARAMETER ( NAMSMX = 270 )
19673 PARAMETER ( NZGVAX = 15 )
19674 PARAMETER ( NISMMX = 574 )
19675 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
19676 & WAPISM (NISMMX), T12ISM (NISMMX),
19677 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19678 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
19679 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19680 & INWAPS (NAMSMX), JSPISM (NISMMX),
19681 & JPTISM (NISMMX), IZWISM (NISMMX),
19682 & INWISM (0:NAMSMX)
19684 CPH SAVE KA0, KZ0, IZ0
19685 DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19689 *======================================================================*
19691 * Entry ENergy - KNOWn *
19693 *======================================================================*
19694 ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19702 * +-------------------------------------------------------------------*
19703 * | Null residual nucleus:
19704 IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19705 IF ( IFLAG .EQ. 1 ) THEN
19713 * +-------------------------------------------------------------------*
19715 ELSE IF ( N .LE. 0 ) THEN
19716 IF ( N .LT. 0 ) THEN
19717 WRITE ( LUNOUT, * )
19718 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19720 WRITE ( LUNOUT, * )
19721 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19724 & ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19726 STOP 'DT_ENERGY:KA0-KZ0'
19729 IF ( IFLAG .EQ. 1 ) THEN
19730 DT_ENERGY = Z * WAPS ( 1, 2 )
19732 DT_ENKNOW = Z * WAPS ( 1, 2 )
19737 * +-------------------------------------------------------------------*
19739 ELSE IF ( KZ0 .LE. 0 ) THEN
19740 IF ( KZ0 .LT. 0 ) THEN
19741 WRITE ( LUNOUT, * )
19742 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19743 WRITE ( LUNOUT, * )
19744 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19746 &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19747 STOP 'DT_ENERGY:KZ0<0'
19750 IF ( IFLAG .EQ. 1 ) THEN
19751 DT_ENERGY = A * WAPS ( 1, 1 )
19753 DT_ENKNOW = A * WAPS ( 1, 1 )
19759 * +-------------------------------------------------------------------*
19760 * +-------------------------------------------------------------------*
19761 * | No actual nucleus
19763 * +-------------------------------------------------------------------*
19764 * +-------------------------------------------------------------------*
19765 * | A larger than maximum allowed:
19766 IF ( KA0 .GT. NAMSMX ) THEN
19768 IF ( IFLAG .EQ. 1 ) THEN
19769 DT_ENERGY = DT_ENRG( A, Z )
19771 DT_ENKNOW = DT_ENRG( A, Z )
19777 * +-------------------------------------------------------------------*
19778 IZZ = INWAPS ( KA0 )
19779 * +-------------------------------------------------------------------*
19780 * | Too much neutron rich with respect to the stability line:
19781 IF ( KZ0 .LT. IZZ ) THEN
19782 * | +----------------------------------------------------------------*
19783 * | | Up to A=Kafree all "bound" masses are known, set it unbound:
19784 IF ( KA0 .LE. KAFREE ) THEN
19787 * | +----------------------------------------------------------------*
19788 * | | Up to Kapuns: be sure it is particle unstable
19789 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19790 * | | Exp. excess mass for A,IZZ
19791 ENEEXP = WAPS ( KA0, 1 )
19792 * | | Cameron excess mass for A, IZZ
19793 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19794 * | | Cameron excess mass for A, Z
19795 DT_ENERGY = DT_ENRG( A, Z )
19796 * | | Use just the difference according to Cameron!!!
19797 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19798 JZZ = INWAPS ( KA0 - 1 )
19799 LZZ = INWAPS ( KA0 - 2 )
19800 * | | +-------------------------------------------------------------*
19801 * | | | Residual mass for n-decay known:
19802 IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19803 IZ0 = KZ0 - JZZ + 1
19804 DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19807 * | | +-------------------------------------------------------------*
19808 * | | | Residual mass for 2n-decay known:
19809 ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19810 IZ0 = KZ0 - LZZ + 1
19811 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19812 & ( WAPS (1,1) + DEPUNS ) )
19814 * | | +-------------------------------------------------------------*
19815 * | | | Set it unbound:
19820 * | | +-------------------------------------------------------------*
19822 * | +----------------------------------------------------------------*
19823 * | | Proceed as usual:
19825 * | | Exp. excess mass for A,IZZ
19826 ENEEXP = WAPS ( KA0, 1 )
19827 * | | Cameron excess mass for A, IZZ
19828 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19829 * | | Cameron excess mass for A, Z
19830 DT_ENERGY = DT_ENRG( A, Z )
19831 * | | Use just the difference according to Cameron!!!
19832 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19835 * | +----------------------------------------------------------------*
19836 * | Be sure not to have a positive energy state:
19837 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19839 IF ( IFLAG .EQ. 2 ) THEN
19840 DT_ENKNOW = DT_ENERGY
19845 * +-------------------------------------------------------------------*
19846 * | Too much proton rich with respect to the stability line:
19847 ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19848 * | +----------------------------------------------------------------*
19849 * | | Up to A=Kafree all "bound" masses are known, set it unbound:
19850 IF ( KA0 .LE. KAFREE ) THEN
19853 * | +----------------------------------------------------------------*
19854 * | | Up to Kapuns: be sure it is particle unstable
19855 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19856 * | | Exp. excess mass for A,IZZ+NZGVAX-1
19857 ENEEXP = WAPS ( KA0, NZGVAX )
19858 * | | Cameron excess mass for A, IZZ+NZGVAX-1
19859 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19860 * | | Cameron excess mass for A, Z
19861 DT_ENERGY = DT_ENRG( A, Z )
19862 * | | Use just the difference according to Cameron!!!
19863 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19864 JZZ = INWAPS ( KA0 - 1 )
19865 LZZ = INWAPS ( KA0 - 2 )
19866 * | | +-------------------------------------------------------------*
19867 * | | | Residual mass for p-decay known:
19868 IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19869 IZ0 = KZ0 - 1 - JZZ + 1
19870 DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19873 * | | +-------------------------------------------------------------*
19874 * | | | Residual mass for 2p-decay known:
19875 ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19877 IZ0 = KZ0 - 2 - LZZ + 1
19878 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19879 & ( WAPS (1,2) + DEPUNS ) )
19881 * | | +-------------------------------------------------------------*
19882 * | | | Set it unbound:
19887 * | | +-------------------------------------------------------------*
19889 * | +----------------------------------------------------------------*
19890 * | | Proceed as usual:
19892 * | | Exp. excess mass for A,IZZ+NZGVAX-1
19893 ENEEXP = WAPS ( KA0, NZGVAX )
19894 * | | Cameron excess mass for A, IZZ+NZGVAX-1
19895 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19896 * | | Cameron excess mass for A, Z
19897 DT_ENERGY = DT_ENRG( A, Z )
19898 * | | Use just the difference according to Cameron!!!
19899 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19902 * | +----------------------------------------------------------------*
19903 * | Be sure not to have a positive energy state:
19904 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19906 IF ( IFLAG .EQ. 2 ) THEN
19907 DT_ENKNOW = DT_ENERGY
19912 * +-------------------------------------------------------------------*
19913 * | Known isotope or anyway isotope "inside" the stability zone
19915 IZ0 = KZ0 - IZZ + 1
19916 DT_ENERGY = WAPS ( KA0, IZ0 )
19917 IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19918 * | +----------------------------------------------------------------*
19919 * | | Mass not known
19920 IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19922 IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19923 * | | +-------------------------------------------------------------*
19924 * | | | Set it unbound:
19925 IF ( KA0 .LE. KAFREE ) THEN
19928 * | | +-------------------------------------------------------------*
19929 * | | | Try to get a reasonable excess mass:
19932 * | | | +----------------------------------------------------------*
19933 * | | | | Check the closest one known:
19934 DO 500 JZZ = 1, NZGVAX
19935 IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19936 & ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19937 IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19940 * | | | +----------------------------------------------------------*
19942 * | | | Exp. excess mass for A,IZZ+JZ0-1
19943 ENEEXP = WAPS ( KA0, JZ0 )
19944 * | | | Cameron excess mass for A, IZZ+JZ0-1
19945 ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19946 * | | | Cameron excess mass for A, Z
19947 DT_ENERGY = DT_ENRG( A, Z )
19948 * | | | Use just the difference according to Cameron!!!
19949 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19953 * | | +-------------------------------------------------------------*
19954 * | | Be sure not to have a positive energy state:
19955 DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19958 * | +----------------------------------------------------------------*
19959 IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19963 * +-------------------------------------------------------------------*
19964 *=== End of Function Energy ===========================================*
19969 *$ CREATE DT_ENRG.FOR
19972 *=== enrg =============================================================*
19974 DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19976 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19979 PARAMETER ( ZERZER = 0.D+00 )
19980 PARAMETER ( ONEONE = 1.D+00 )
19981 PARAMETER ( LUNIN = 5 )
19982 PARAMETER ( LUNOUT = 6 )
19984 *----------------------------------------------------------------------*
19986 * Revised version of the original routine from EVAP: *
19988 * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
19991 * Last change on 01-oct-94 by Alfredo Ferrari *
19993 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19994 * !!! It is supposed to be used with the updated atomic !!! *
19995 * !!! mass data file !!! *
19996 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19998 *----------------------------------------------------------------------*
20000 PARAMETER ( O16OLD = 931.145 D+00 )
20001 PARAMETER ( O16NEW = 931.19826D+00 )
20002 PARAMETER ( O16RAT = O16NEW / O16OLD )
20003 PARAMETER ( C12NEW = 931.49432D+00 )
20004 PARAMETER ( ADJUST = -8.322737768178909D-02 )
20005 PARAMETER ( AINFNT = 1.0D+30 )
20006 * (original name: EVA0)
20007 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20008 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20009 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20010 * T (4,7), RMASS (297), ALPH (297), BET (297),
20011 * APRIME (250), IA (6), IZ (6)
20013 CPH SAVE LFIRST, EXHYDR, EXNEUT
20014 DATA LFIRST / .TRUE. /
20019 C EXHYDR = DT_ENERGY( ONEONE, ONEONE )
20020 C EXNEUT = DT_ENERGY( ONEONE, ZERZER )
20028 IF ( IZ0 .LE. 0 ) THEN
20029 DT_ENRG = A * EXNEUT
20033 IF ( N .LE. 0 ) THEN
20034 DT_ENRG = Z * EXHYDR
20038 AM2ZOA=AM2ZOA*AM2ZOA
20039 A13 = RMASS(NINT(A))
20040 * A13 = A**.3333333333333333D+00
20042 EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20043 ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20044 & (1.D+00 -0.62025D+00*AM13*AM13)*
20045 & (A13*A13 -.62025D+00)
20046 EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20047 & AM13-1.5849D+00)*
20048 & AM13*AM13 +1.D+00)
20049 EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20050 & (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20052 DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20053 DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20054 DT_ENRG = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20056 *=== End of function Enrg =============================================*
20059 *$ CREATE DT_INCINI.FOR
20062 *=== incini ===========================================================*
20064 SUBROUTINE DT_INCINI
20066 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20069 PARAMETER ( ZERZER = 0.D+00 )
20070 PARAMETER ( ONEONE = 1.D+00 )
20071 PARAMETER ( TWOTWO = 2.D+00 )
20072 PARAMETER ( THRTHR = 3.D+00 )
20073 PARAMETER ( FOUFOU = 4.D+00 )
20074 PARAMETER ( EIGEIG = 8.D+00 )
20075 PARAMETER ( ANINEN = 9.D+00 )
20076 PARAMETER ( HLFHLF = 0.5D+00 )
20077 PARAMETER ( ONETHI = ONEONE / THRTHR )
20078 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20079 PARAMETER ( PLABRC = 0.197327053 D+00 )
20080 PARAMETER ( AMELCT = 0.51099906 D-03 )
20081 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20082 PARAMETER ( AMPRTN = 0.93827231 D+00 )
20083 PARAMETER ( AMNTRN = 0.93956563 D+00 )
20084 PARAMETER ( AMDEUT = 1.87561339 D+00 )
20085 PARAMETER ( EMVGEV = 1.0 D-03 )
20087 PARAMETER ( LUNOUT = 6 )
20089 *----------------------------------------------------------------------*
20091 * Created on 10 june 1990 by Alfredo Ferrari & Paola Sala *
20094 * Last change on 02-may-95 by Alfredo Ferrari *
20097 *----------------------------------------------------------------------*
20099 * (original name: FHEAVY,FHEAVC)
20100 PARAMETER ( MXHEAV = 100 )
20102 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20103 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20104 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20105 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
20106 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
20107 & IBHEAV ( 12 ) , NPHEAV
20108 COMMON /FKFHVC/ ANHEAV ( 12 )
20109 * (original name: INPFLG)
20110 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20111 * (original name: FRBKCM)
20112 PARAMETER ( MXFFBK = 6 )
20113 PARAMETER ( MXZFBK = 9 )
20114 PARAMETER ( MXNFBK = 10 )
20115 PARAMETER ( MXAFBK = 16 )
20116 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20117 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20118 PARAMETER ( NXAFBK = MXAFBK + 1 )
20119 PARAMETER ( MXPSST = 300 )
20120 PARAMETER ( MXPSFB = 41000 )
20121 LOGICAL LFRMBK, LNCMSS
20122 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20123 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20124 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20125 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20126 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20127 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20128 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20129 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20130 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20131 * (original name: NUCDAT)
20132 PARAMETER ( AMUAMU = AMUGEV )
20133 PARAMETER ( AMPROT = AMPRTN )
20134 PARAMETER ( AMNEUT = AMNTRN )
20135 PARAMETER ( AMELEC = AMELCT )
20136 PARAMETER ( R0NUCL = 1.12 D+00 )
20137 PARAMETER ( RCCOUL = 1.7 D+00 )
20138 PARAMETER ( FERTHO = 14.33 D-09 )
20139 PARAMETER ( EXPEBN = 2.39 D+00 )
20140 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20141 PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20142 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
20143 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
20144 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
20145 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20146 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20147 PARAMETER ( GAMMIN = 1.0D-06 )
20148 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20149 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20150 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
20151 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
20152 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20153 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20154 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20155 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20156 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
20157 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
20158 * (original name: PAREVT)
20159 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20160 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20161 PARAMETER ( NALLWP = 39 )
20162 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20163 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20164 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20165 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20166 * (original name: NUCOLD)
20167 COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20168 & EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20174 APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20175 AMNUCL (1) = AMPROT
20176 AMNUCL (2) = AMNEUT
20177 AMNUSQ (1) = AMPROT * AMPROT
20178 AMNUSQ (2) = AMNEUT * AMNEUT
20179 AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20181 * ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20182 AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20183 AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20184 & ( 5.6D+00 * ASQHLP ) )
20185 AV0WEL = AEFRMX + EBNDAV
20186 EBNDNG (1) = EBNDAV
20187 EBNDNG (2) = EBNDAV
20188 AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20189 CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20190 AMMC12 = 12.D+00 * AMUGEV + AEXC12
20191 AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20192 AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20193 CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20194 AMMO16 = 16.D+00 * AMUGEV + AEXO16
20195 AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20196 AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20197 CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20198 AMMS28 = 28.D+00 * AMUGEV + AEXS28
20199 AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20200 AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20201 CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20202 AMMC40 = 40.D+00 * AMUGEV + AEXC40
20203 AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20204 AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20205 CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20206 AMMF56 = 56.D+00 * AMUGEV + AEXF56
20207 AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20208 AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20209 CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20210 AMM107 = 107.D+00 * AMUGEV + AEX107
20211 AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20212 AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20213 CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20214 AMM132 = 132.D+00 * AMUGEV + AEX132
20215 AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20216 AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20217 CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20218 AMM181 = 181.D+00 * AMUGEV + AEX181
20219 AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20220 AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20221 CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20222 AMM208 = 208.D+00 * AMUGEV + AEX208
20223 AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20224 AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20225 CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20226 AMM238 = 238.D+00 * AMUGEV + AEX238
20227 AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20229 AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20230 AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20231 AMHEAV (3) = TWOTWO * AMUGEV
20232 & + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20233 AMHEAV (4) = THRTHR * AMUGEV
20234 & + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20235 AMHEAV (5) = THRTHR * AMUGEV
20236 & + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20237 AMHEAV (6) = FOUFOU * AMUGEV
20238 & + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20239 ELBNDE (0) = ZERZER
20240 ELBNDE (1) = 13.6D-09
20241 DO 2000 IZ = 2, 100
20242 ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
20244 AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20245 AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20246 AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20247 AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20248 AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20249 AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20251 WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20252 & ' activated **** '
20253 IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20254 & ' production activated **** '
20256 * commented, since obsolete
20257 C IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20258 C & ' transport activated **** '
20259 IF ( IFISS .GT. 0 )
20260 & WRITE ( LUNOUT, * )' **** High Energy fission ',
20261 & ' requested & activated **** '
20263 & WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20264 & ' requested & activated **** '
20265 IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20273 *=== End of subroutine incini =========================================*
20276 *$ CREATE DT_STALIN.FOR
20279 *=== stalin ===========================================================*
20281 SUBROUTINE DT_STALIN
20283 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20285 PARAMETER ( ANGLGB = 5.0D-16 )
20286 PARAMETER ( ZERZER = 0.D+00 )
20287 PARAMETER ( ONEONE = 1.D+00 )
20288 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20289 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20290 PARAMETER ( EMVGEV = 1.0 D-03 )
20291 PARAMETER ( NSTBIS = 304 )
20292 PARAMETER ( LUNIN = 5 )
20293 PARAMETER ( LUNOUT = 6 )
20295 *----------------------------------------------------------------------*
20297 * STAbility LINe calculation: *
20299 * Created on 04 december 1992 by Alfredo Ferrari & Paola Sala *
20302 * Last change on 04-dec-92 by Alfredo Ferrari *
20305 *----------------------------------------------------------------------*
20307 * (original name: ISOTOP)
20308 PARAMETER ( NAMSMX = 270 )
20309 PARAMETER ( NZGVAX = 15 )
20310 PARAMETER ( NISMMX = 574 )
20311 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20312 & WAPISM (NISMMX), T12ISM (NISMMX),
20313 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20314 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20315 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20316 & INWAPS (NAMSMX), JSPISM (NISMMX),
20317 & JPTISM (NISMMX), IZWISM (NISMMX),
20318 & INWISM (0:NAMSMX)
20320 DIMENSION ZNORM (260)
20321 * +-------------------------------------------------------------------*
20325 ASTLIN (J,IZ) = ZERZER
20329 * +-------------------------------------------------------------------*
20330 * +-------------------------------------------------------------------*
20333 ZNORM (IA) = ZERZER
20335 ZSTLIN (J,IA) = ZERZER
20339 * +-------------------------------------------------------------------*
20340 * +-------------------------------------------------------------------*
20341 * | Loop on the Atomic Number
20343 AMSSST (IZ) = ZERZER
20346 * | +----------------------------------------------------------------*
20347 * | | Loop on the stable isotopes
20348 DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20350 ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20351 ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20352 ZNORM (IA) = ZNORM (IA) + ABUISO (IS)
20353 ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20354 ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20356 IF ( AHELP .LE. 1.00001D+00 ) THEN
20357 ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20360 AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20361 & + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20364 * | +----------------------------------------------------------------*
20365 AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20366 * | Normalize and print A_stab versus Z data:
20367 ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20369 * WRITE (LUNOUT,*)' Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20370 * & ' Sigma_st',SNGL(ASTLIN(2,IZ))
20373 * +-------------------------------------------------------------------*
20374 * +-------------------------------------------------------------------*
20375 * | Normalize and print Z_stab versus A data:
20377 ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20378 ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20379 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20380 IF ( ZNORM (IA) .GT. ANGLGB )
20381 **sr 2.11. avoid underflows at Pentium
20383 & MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20384 C & ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20388 * +-------------------------------------------------------------------*
20389 * +-------------------------------------------------------------------*
20390 * | Normalize and print Z_stab versus A data:
20392 IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20393 DO 4200 JA = IA-1,1,-1
20394 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20400 DO 4400 JA = IA+1,260
20401 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20409 ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20410 & * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20412 ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20413 & * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20416 IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20417 ATOZ = IZ / ASTLIN (1,IZ)
20418 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20419 * WRITE (LUNOUT,*)' A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20420 * & ' Sigma_st',SNGL(ZSTLIN(2,IA))
20423 * +-------------------------------------------------------------------*
20427 *$ CREATE DT_BERTTP.FOR
20430 *=== berttp ===========================================================*
20432 SUBROUTINE DT_BERTTP
20434 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20437 PARAMETER ( CSNNRM = 2.0D-15 )
20438 PARAMETER ( ZERZER = 0.D+00 )
20439 PARAMETER ( ONEONE = 1.D+00 )
20440 PARAMETER ( THRTHR = 3.D+00 )
20441 PARAMETER ( SIXSIX = 6.D+00 )
20442 PARAMETER ( ONETHI = ONEONE / THRTHR )
20443 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20444 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20445 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20446 PARAMETER ( EMVGEV = 1.0 D-03 )
20448 PARAMETER ( NSTBIS = 304 )
20450 PARAMETER ( LUNIN = 5 )
20451 PARAMETER ( LUNOUT = 6 )
20452 **sr 19.5. set error output-unit from 15 to 6
20453 PARAMETER ( LUNERR = 6 )
20454 C---------------------------------------------------------------------
20455 C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20456 C---------------------------------------------------------------------
20457 C ---------------------------------- I-N-C DATA
20458 C COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20459 C REAL*8 R8,R8B,CRSC,CS
20461 C --------------------------------- EVAPORATION DATA
20462 * (original name: COOKCM)
20463 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20464 LOGICAL LDEFOZ, LDEFON
20465 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20466 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20467 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20468 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20469 * (original name: EVA0)
20470 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20471 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20472 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20473 * T (4,7), RMASS (297), ALPH (297), BET (297),
20474 * APRIME (250), IA (6), IZ (6)
20475 * (original name: FRBKCM)
20476 PARAMETER ( MXFFBK = 6 )
20477 PARAMETER ( MXZFBK = 9 )
20478 PARAMETER ( MXNFBK = 10 )
20479 PARAMETER ( MXAFBK = 16 )
20480 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20481 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20482 PARAMETER ( NXAFBK = MXAFBK + 1 )
20483 PARAMETER ( MXPSST = 300 )
20484 PARAMETER ( MXPSFB = 41000 )
20485 LOGICAL LFRMBK, LNCMSS
20486 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20487 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20488 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20489 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20490 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20491 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20492 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20493 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20494 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20495 * (original name: HETTP)
20496 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
20497 * (original name: INPFLG)
20498 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20499 * (original name: ISOTOP)
20500 PARAMETER ( NAMSMX = 270 )
20501 PARAMETER ( NZGVAX = 15 )
20502 PARAMETER ( NISMMX = 574 )
20503 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20504 & WAPISM (NISMMX), T12ISM (NISMMX),
20505 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20506 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20507 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20508 & INWAPS (NAMSMX), JSPISM (NISMMX),
20509 & JPTISM (NISMMX), IZWISM (NISMMX),
20510 & INWISM (0:NAMSMX)
20511 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20512 PARAMETER ( PI = PIPIPI )
20513 PARAMETER ( PISQ = PIPISQ )
20514 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20515 PARAMETER ( RZNUCL = 1.12 D+00 )
20516 PARAMETER ( RMSPRO = 0.8 D+00 )
20517 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
20518 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20520 PARAMETER ( RLLE04 = RZNUCL )
20521 PARAMETER ( RLLE16 = RZNUCL )
20522 PARAMETER ( RLGT16 = RZNUCL )
20523 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20524 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20525 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20526 PARAMETER ( SKLE04 = 1.4D+00 )
20527 PARAMETER ( SKLE16 = 1.9D+00 )
20528 PARAMETER ( SKGT16 = 2.4D+00 )
20529 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20530 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20531 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20532 PARAMETER ( ALPHA0 = 0.1D+00 )
20533 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20534 PARAMETER ( GAMSK0 = 0.9D+00 )
20535 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20536 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20537 PARAMETER ( POTBA0 = 1.D+00 )
20538 PARAMETER ( PNFRAT = 1.533D+00 )
20539 PARAMETER ( RADPIM = 0.035D+00 )
20540 PARAMETER ( RDPMHL = 14.D+00 )
20541 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20542 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20543 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20544 PARAMETER ( AP0PFS = 0.5D+00 )
20545 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20546 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20547 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20548 PARAMETER ( MXSCIN = 50 )
20549 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20550 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20551 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20552 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20553 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20554 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20556 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20557 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20558 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20559 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20560 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20561 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20562 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20563 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20564 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20565 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20566 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20567 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20568 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20569 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20570 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20571 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20572 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20573 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20574 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20575 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20576 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20577 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20578 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20579 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20580 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20581 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
20582 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20583 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20584 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20585 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20586 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20587 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20588 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20589 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20590 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20591 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20592 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20593 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20594 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20595 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20597 DIMENSION AWSTAB (2:260), SIGMAB (3)
20598 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20599 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20600 EQUIVALENCE ( RHOIPP, RHONCP (1) )
20601 EQUIVALENCE ( RHOINP, RHONCP (2) )
20602 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20603 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20604 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20605 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20606 EQUIVALENCE ( RHOIPT, RHONCT (1) )
20607 EQUIVALENCE ( RHOINT, RHONCT (2) )
20608 EQUIVALENCE ( OMALHL, SK3PAR )
20609 EQUIVALENCE ( ALPHAL, HABPAR )
20610 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20611 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20612 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20613 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20614 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20615 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20616 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20617 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20618 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20619 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20620 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20621 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20622 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20623 * (original name: NUCLEV)
20624 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20625 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20626 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20627 & CUMRAD (0:160,2), RUSNUC (2),
20628 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20629 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20630 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20631 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20632 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20633 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20634 & LFLVSL, LRLVSL, LEQSBL
20635 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20636 & MGSSPR (19) , MGSSNE (25)
20637 EQUIVALENCE ( RUSNUC (1), RUSPRO )
20638 EQUIVALENCE ( RUSNUC (2), RUSNEU )
20639 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20640 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20641 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20642 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20643 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20644 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20645 EQUIVALENCE ( NTANUC (1), NTAPRO )
20646 EQUIVALENCE ( NTANUC (2), NTANEU )
20647 EQUIVALENCE ( NAVNUC (1), NAVPRO )
20648 EQUIVALENCE ( NAVNUC (2), NAVNEU )
20649 EQUIVALENCE ( NLSNUC (1), NLSPRO )
20650 EQUIVALENCE ( NLSNUC (2), NLSNEU )
20651 EQUIVALENCE ( NCONUC (1), NCOPRO )
20652 EQUIVALENCE ( NCONUC (2), NCONEU )
20653 EQUIVALENCE ( NSKNUC (1), NSKPRO )
20654 EQUIVALENCE ( NSKNUC (2), NSKNEU )
20655 EQUIVALENCE ( NHANUC (1), NHAPRO )
20656 EQUIVALENCE ( NHANUC (2), NHANEU )
20657 EQUIVALENCE ( NUSNUC (1), NUSPRO )
20658 EQUIVALENCE ( NUSNUC (2), NUSNEU )
20659 EQUIVALENCE ( NACNUC (1), NACPRO )
20660 EQUIVALENCE ( NACNUC (2), NACNEU )
20661 EQUIVALENCE ( JMXNUC (1), JMXPRO )
20662 EQUIVALENCE ( JMXNUC (2), JMXNEU )
20663 EQUIVALENCE ( MAGNUC (1), MAGPRO )
20664 EQUIVALENCE ( MAGNUC (2), MAGNEU )
20665 * (original name: PAREVT)
20666 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20667 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20668 PARAMETER ( NALLWP = 39 )
20669 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20670 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20671 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20672 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20673 * (original name: XSEPAR)
20674 COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20675 & DDNXSE (100), EENXSE (100), ZZNXSE (100),
20676 & EMNXSE (100), XMNXSE (100),
20677 & AAPXSE (100), BBPXSE (100), CCPXSE (100),
20678 & DDPXSE (100), EEPXSE (100), FFPXSE (100),
20679 & ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20681 C---------------------------------------------------------------------
20683 * modified for use in DPMJET
20684 C WRITE( LUNOUT,'(A,I2)')
20685 C & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20687 IF (LEVPRT) WRITE(LUNOUT,1000)
20688 1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20689 & /,12X,'------------------------------------',/)
20691 CPH OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
20694 *!!!! changed to be able to read the ASCII !!!!
20696 C A. Ferrari: first of all read isotopic data
20697 READ (NBERNW,*) ISONDX
20698 READ (NBERNW,*) ISOMNM
20699 READ (NBERNW,*) ABUISO
20700 C READ (NBERTP) ISONDX
20701 C READ (NBERTP) ISOMNM
20702 C READ (NBERTP) ABUISO
20704 C READ (NBERTP) (CRSC(J,I),J=1,600)
20705 C A. Ferrari: commented also the dummy read to save disk space
20709 C A. Ferrari: commented also the dummy read to save disk space
20711 C---------------------------------------------------------------------
20712 READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20713 READ (NBERNW,*) IA,IZ
20718 READ (NBERNW,*) RHO,OMEGA
20719 READ (NBERNW,*) EXMASS
20720 READ (NBERNW,*) CAM2
20721 READ (NBERNW,*) CAM3
20722 READ (NBERNW,*) CAM4
20723 READ (NBERNW,*) CAM5
20724 READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20728 READ (NBERNW,*) RMASS
20729 READ (NBERNW,*) ALPH
20730 READ (NBERNW,*) BET
20731 READ (NBERNW,*) INWAPS
20732 READ (NBERNW,*) WAPS
20733 READ (NBERNW,*) T12NUC
20734 READ (NBERNW,*) JSPNUC
20735 READ (NBERNW,*) JPTNUC
20736 READ (NBERNW,*) INWISM
20737 READ (NBERNW,*) IZWISM
20738 READ (NBERNW,*) WAPISM
20739 READ (NBERNW,*) T12ISM
20740 READ (NBERNW,*) JSPISM
20741 READ (NBERNW,*) JPTISM
20742 READ (NBERNW,*) APRIME
20744 &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20745 READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20746 IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20747 & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20749 & ' *** Inconsistent Nuclear Geometry data on file ***'
20752 READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20753 & EKATAB, PFATAB, PFRTAB
20754 READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20756 READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20757 & ZZPXSE, EMPXSE, XMPXSE
20758 * Data about Fermi-breakup:
20759 READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20760 IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20761 & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20762 WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20763 & ' in the Nuclear Data file ***'
20764 STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20766 READ (NBERNW,*) IFRBKN
20767 READ (NBERNW,*) IFRBKZ
20768 READ (NBERNW,*) IFBKSP
20769 READ (NBERNW,*) IFBKST
20770 READ (NBERNW,*) EEXFBK
20772 CLOSE (UNIT=NBERNW)
20774 C READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20775 C READ (NBERTP) IA,IZ
20780 C READ (NBERTP) RHO,OMEGA
20781 C READ (NBERTP) EXMASS
20782 C READ (NBERTP) CAM2
20783 C READ (NBERTP) CAM3
20784 C READ (NBERTP) CAM4
20785 C READ (NBERTP) CAM5
20786 C READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20790 C READ (NBERTP) RMASS
20791 C READ (NBERTP) ALPH
20792 C READ (NBERTP) BET
20793 C READ (NBERTP) INWAPS
20794 C READ (NBERTP) WAPS
20795 C READ (NBERTP) T12NUC
20796 C READ (NBERTP) JSPNUC
20797 C READ (NBERTP) JPTNUC
20798 C READ (NBERTP) INWISM
20799 C READ (NBERTP) IZWISM
20800 C READ (NBERTP) WAPISM
20801 C READ (NBERTP) T12ISM
20802 C READ (NBERTP) JSPISM
20803 C READ (NBERTP) JPTISM
20804 C READ (NBERTP) APRIME
20805 C WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20806 C READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20807 C IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20808 C & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20810 C & ' *** Inconsistent Nuclear Geometry data on file ***'
20813 C READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20814 C & EKATAB, PFATAB, PFRTAB
20815 C READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20817 C READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20818 C & ZZPXSE, EMPXSE, XMPXSE
20819 * Data about Fermi-breakup:
20820 C READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20821 C IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20822 C & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20823 C WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20824 C & ' in the Nuclear Data file ***'
20825 C STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20827 C READ (NBERTP) IFRBKN
20828 C READ (NBERTP) IFRBKZ
20829 C READ (NBERTP) IFBKSP
20830 C READ (NBERTP) IFBKST
20831 C READ (NBERTP) EEXFBK
20832 C CLOSE (UNIT=NBERTP)
20834 SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20837 SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20840 IF ( ILVMOD .LE. 0 ) THEN
20846 DO 300 JZ = 1, IZCOOK
20847 CAM4 (JZ) = PZCOOK (JZ)
20849 DO 400 JN = 1, INCOOK
20850 CAM5 (JN) = PNCOOK (JZ)
20856 IF ( ILVMOD .EQ. 1 ) THEN
20858 & ' **** Standard EVAP T=0 level density used ****'
20859 ELSE IF ( ILVMOD .EQ. 2 ) THEN
20861 & ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20862 ELSE IF ( ILVMOD .EQ. 3 ) THEN
20864 & ' **** Julich A-dependent level density used ****'
20865 ELSE IF ( ILVMOD .EQ. 4 ) THEN
20867 & ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20871 & ' **** Unknown T=0 level density option requested ****'
20872 STOP 'BERTTP-ILVMOD'
20874 IF ( JLVMOD .LE. 0 ) THEN
20877 & ' **** No Excitation en. dependence for level densities ****'
20878 ELSE IF ( JLVMOD .EQ. 1 ) THEN
20880 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20882 & ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20888 ELSE IF ( JLVMOD .EQ. 2 ) THEN
20890 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20892 & ' **** with UNKNOWN set of parameters for T=oo ****'
20893 STOP 'BERTTP-JLVMOD'
20894 ELSE IF ( JLVMOD .EQ. 3 ) THEN
20896 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20898 & ' **** with UNKNOWN set of parameters for T=oo ****'
20899 STOP 'BERTTP-JLVMOD'
20900 ELSE IF ( JLVMOD .EQ. 4 ) THEN
20902 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20904 & ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20910 ELSE IF ( JLVMOD .EQ. 5 ) THEN
20912 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20914 & ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20919 ELSE IF ( JLVMOD .EQ. 6 ) THEN
20921 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20923 & ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20928 ELSE IF ( JLVMOD .EQ. 7 ) THEN
20930 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20932 & ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20937 ELSE IF ( JLVMOD .EQ. 8 ) THEN
20939 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20941 & ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20948 & ' **** Unknown T=oo level density option requested ****'
20949 STOP 'BERTTP-JLVMOD'
20953 & ' **** Cook''s modified pairing energy used ****'
20956 & ' **** Original Gilbert/Cameron pairing energy used ****'
20963 PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20966 PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20971 *$ CREATE DT_EVEVAP.FOR
20974 *====evevap============================================================*
20976 SUBROUTINE DT_EVEVAP(WE)
20978 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20980 PARAMETER ( LINP = 10 ,
20984 * flags for input different options
20985 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20986 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20987 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20994 *$ CREATE DT_FRBKIN.FOR
20997 *====frbkin============================================================*
20999 SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
21001 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21003 PARAMETER ( LINP = 10 ,
21007 LOGICAL LDUM1,LDUM2
21012 *$ CREATE DT_EXPLOD.FOR
21015 *=== explod ===========================================================*
21017 SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
21020 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21023 DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21024 & ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21029 ************************************************************************
21031 * DPMJET 3.0: cross section routines *
21033 ************************************************************************
21036 * SUBROUTINE DT_SHNDIF
21037 * diffractive cross sections (all energies)
21038 * SUBROUTINE DT_PHOXS
21039 * total and inel. cross sections from PHOJET interpol. tables
21040 * SUBROUTINE DT_XSHN
21041 * total and el. cross sections for all energies
21042 * SUBROUTINE DT_SIHNAB
21043 * pion 2-nucleon absorption cross sections
21044 * SUBROUTINE DT_SIGEMU
21045 * cross section for target "compounds"
21046 * SUBROUTINE DT_SIGGA
21047 * photon nucleus cross sections
21048 * SUBROUTINE DT_SIGGAT
21049 * photon nucleus cross sections from tables
21050 * SUBROUTINE DT_SANO
21051 * anomalous hard photon-nucleon cross sections from tables
21052 * SUBROUTINE DT_SIGGP
21053 * photon nucleon cross sections
21054 * SUBROUTINE DT_SIGVEL
21055 * quasi-elastic vector meson prod. cross sections
21056 * DOUBLE PRECISION FUNCTION DT_SIGVP
21058 * DOUBLE PRECISION FUNCTION DT_RRM2
21059 * DOUBLE PRECISION FUNCTION DT_RM2
21060 * DOUBLE PRECISION FUNCTION DT_SAM2
21061 * SUBROUTINE DT_CKMT
21062 * SUBROUTINE DT_CKMTX
21063 * SUBROUTINE DT_PDF0
21064 * SUBROUTINE DT_CKMTQ0
21065 * SUBROUTINE DT_CKMTDE
21066 * SUBROUTINE DT_CKMTPR
21067 * FUNCTION DT_CKMTFF
21069 * SUBROUTINE DT_FLUINI
21070 * total nucleon cross section fluctuation treatment
21072 * SUBROUTINE DT_SIGTBL
21073 * pre-tabulation of low-energy elastic x-sec. using SIHNEL
21074 * SUBROUTINE DT_XSTABL
21078 *$ CREATE DT_SHNDIF.FOR
21081 *===shndif===============================================================*
21083 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21085 **********************************************************************
21086 * Single diffractive hadron-nucleon cross sections *
21087 * S.Roesler 14/1/93 *
21089 * The cross sections are calculated from extrapolated single *
21090 * diffractive antiproton-proton cross sections (DTUJET92) using *
21091 * scaling relations between total and single diffractive cross *
21093 **********************************************************************
21095 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21097 PARAMETER (ZERO=0.0D0)
21099 * particle properties (BAMJET index convention)
21101 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21102 & IICH(210),IIBAR(210),K1(210),K2(210)
21104 CSD1 = 4.201483727D0
21105 CSD4 = -0.4763103556D-02
21106 CSD5 = 0.4324148297D0
21108 CHMSD1 = 0.8519297242D0
21109 CHMSD4 = -0.1443076599D-01
21110 CHMSD5 = 0.4014954567D0
21112 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21113 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21115 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21116 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21117 FRAC = SHMSD/SDIAPP
21119 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21120 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21121 & 10, 10, 20, 20, 20) KPROJ
21124 *---------------------------- p - p , n - p , sigma0+- - p ,
21126 CSD1 = 6.004476070D0
21127 CSD4 = -0.1257784606D-03
21128 CSD5 = 0.2447335720D0
21129 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21130 SIGDIH = FRAC*SIGDIF
21137 C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21139 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21142 C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21143 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21145 SIGDIH = FRAC*SIGDIF
21149 *-------------------------- leptons..
21155 *$ CREATE DT_PHOXS.FOR
21158 *===phoxs================================================================*
21160 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21162 ************************************************************************
21163 * Total/inelastic proton-nucleon cross sections taken from PHOJET- *
21164 * interpolation tables. *
21165 * This version dated 05.11.97 is written by S. Roesler *
21166 ************************************************************************
21168 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21171 PARAMETER ( LINP = 10 ,
21174 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21175 PARAMETER (TWOPI = 6.283185307179586454D+00,
21177 & GEV2MB = 0.38938D0)
21180 DATA LFIRST /.TRUE./
21182 * nucleon-nucleon event-generator
21185 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21186 * particle properties (BAMJET index convention)
21188 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21189 & IICH(210),IIBAR(210),K1(210),K2(210)
21192 C PARAMETER (IEETAB=10)
21193 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21195 C energy-interpolation table
21197 PARAMETER ( IEETA2 = 20 )
21199 DOUBLE PRECISION SIGTAB,SIGECM
21200 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21203 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21204 WRITE(LOUT,*) MCGENE
21205 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21209 IF (ECM.LE.ZERO) THEN
21210 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21211 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21214 IF (MODE.EQ.1) THEN
21219 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21221 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
21222 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21228 IF(ECM.LE.SIGECM(IP,1)) THEN
21231 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21233 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21240 WRITE(LOUT,'(/1X,A,2E12.3)')
21241 & 'PHOXS: warning! energy above initialization limit (',
21242 & ECM,SIGECM(IP,ISIMAX)
21249 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21250 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21252 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21253 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21254 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21255 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21256 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21262 *$ CREATE DT_XSHN.FOR
21265 *===xshn===============================================================*
21267 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21269 ************************************************************************
21270 * Total and elastic hadron-nucleon cross section. *
21271 * Below 500GeV cross sections are based on the '98 data compilation *
21272 * of the PDG. At higher energies PHOJET results are used (patched to *
21273 * the low energy data at 500GeV). *
21274 * IP projectile index (BAMJET numbering scheme) *
21275 * (should be in the range 1..25) *
21276 * IT target index (BAMJET numbering scheme) *
21277 * (1 = proton, 8 = neutron) *
21278 * PL laboratory momentum *
21279 * ECM cm. energy (ignored if PL>0) *
21280 * STOT total cross section *
21281 * SELA elastic cross section *
21282 * Last change: 24.4.99 by S. Roesler *
21283 ************************************************************************
21285 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21288 PARAMETER ( LINP = 10 ,
21291 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21293 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21294 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21295 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21298 * particle properties (BAMJET index convention)
21300 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21301 & IICH(210),IIBAR(210),K1(210),K2(210)
21302 * nucleon-nucleon event-generator
21305 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21307 C PARAMETER (IEETAB=10)
21308 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21310 C energy-interpolation table
21312 PARAMETER ( IEETA2 = 20 )
21314 DOUBLE PRECISION SIGTAB,SIGECM
21315 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21317 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21318 DIMENSION IDXDAT(25,2)
21321 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21322 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21323 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21324 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21325 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21326 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21327 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21329 * total cross sections:
21331 DATA (ASIGTO(1,K),K=1,NPOINT) /
21332 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21333 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21334 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21335 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21336 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21337 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21338 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21340 DATA (ASIGTO(2,K),K=1,NPOINT) /
21341 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21342 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21343 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21344 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21345 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21346 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21347 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21349 DATA (ASIGTO(3,K),K=1,NPOINT) /
21350 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21351 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21352 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21353 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21354 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21355 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21356 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21358 DATA (ASIGTO(4,K),K=1,NPOINT) /
21359 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21360 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21361 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21362 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21363 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21364 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21365 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21367 DATA (ASIGTO(5,K),K=1,NPOINT) /
21368 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21369 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21370 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21371 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21372 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21373 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21374 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21376 DATA (ASIGTO(6,K),K=1,NPOINT) /
21377 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21378 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21379 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21380 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21381 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21382 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21383 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21385 DATA (ASIGTO(7,K),K=1,NPOINT) /
21386 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21387 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21388 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21389 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21390 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21391 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21392 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21394 DATA (ASIGTO(8,K),K=1,NPOINT) /
21395 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21396 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21397 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21398 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21399 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21400 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21401 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21403 DATA (ASIGTO(9,K),K=1,NPOINT) /
21404 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21405 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21406 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21407 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21408 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21409 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21410 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21412 DATA (ASIGTO(10,K),K=1,NPOINT) /
21413 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21414 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21415 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21416 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21417 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21418 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21419 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21421 * elastic cross sections:
21423 DATA (ASIGEL(1,K),K=1,NPOINT) /
21424 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21425 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21426 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21427 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21428 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21429 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21430 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21432 DATA (ASIGEL(2,K),K=1,NPOINT) /
21433 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21434 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21435 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21436 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21437 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21438 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21439 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21441 DATA (ASIGEL(3,K),K=1,NPOINT) /
21442 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21443 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21444 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21445 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21446 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21447 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21448 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21450 DATA (ASIGEL(4,K),K=1,NPOINT) /
21451 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21452 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21453 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21454 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21455 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21456 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21457 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21459 DATA (ASIGEL(5,K),K=1,NPOINT) /
21460 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21461 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21462 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21463 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21464 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21465 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21466 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21468 DATA (ASIGEL(6,K),K=1,NPOINT) /
21469 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21470 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21471 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21472 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21473 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21474 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21475 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21477 DATA (ASIGEL(7,K),K=1,NPOINT) /
21478 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21479 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21480 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21481 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21482 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21483 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21484 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21486 DATA (ASIGEL(8,K),K=1,NPOINT) /
21487 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21488 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21489 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21490 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21491 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21492 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21493 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21495 DATA (ASIGEL(9,K),K=1,NPOINT) /
21496 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21497 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21498 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21499 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21500 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21501 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21502 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21504 DATA (ASIGEL(10,K),K=1,NPOINT) /
21505 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21506 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21507 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21508 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21509 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21510 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21511 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21513 DATA (IDXDAT(K,1),K=1,25) /
21514 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21516 DATA (IDXDAT(K,2),K=1,25) /
21517 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21520 DATA LFIRST /.TRUE./
21523 APLABL = LOG10(PLABLO)
21524 APLABH = LOG10(PLABHI)
21525 APTHRE = LOG10(PTHRE)
21526 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21527 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21530 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21531 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21532 IF (MCGENE.EQ.2) THEN
21533 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21534 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21536 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21539 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21541 PHOSEL = PHOSTO-PHOSIN
21542 APHOST = LOG10(PHOSTO)
21543 APHOSE = LOG10(PHOSEL)
21550 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21551 WRITE(LOUT,1000) IP,IT
21552 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21553 & 'proj/target',2I4)
21557 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21558 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21559 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21560 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21561 WRITE(LOUT,1001) PLAB,ECMS
21562 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21566 * index of spectrum
21569 IF (AAM(IP).GT.ZERO) THEN
21570 IF (ABS(IIBAR(IP)).GT.0) THEN
21580 IF (IT.EQ.8) IDXT = 2
21581 IDXS = IDXDAT(IDXP,IDXT)
21582 IF (IDXS.EQ.0) RETURN
21584 * compute momentum bin indices
21585 IF (PLAB.LT.PLABLO) THEN
21588 ELSEIF (PLAB.GE.PLABHI) THEN
21592 APLAB = LOG10(PLAB)
21593 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21594 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21595 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21596 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21601 * interpolate cross section
21602 IF (IDXS.GT.10) THEN
21604 IDXS2 = IDXS-10*IDXS1
21605 IF (IDX0.EQ.IDX1) THEN
21606 IF (IDX0.EQ.1) THEN
21607 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21608 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21611 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21612 PHOSEL = PHOSTO-PHOSIN
21613 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21614 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21615 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21616 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21617 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21618 ASELA = 0.5D0*(ASELA1+ASELA2)
21621 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21622 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21623 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21624 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21625 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21626 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21627 ASELA1 = ASIGEL(IDXS1,IDX0)+
21628 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21629 ASELA2 = ASIGEL(IDXS2,IDX0)+
21630 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21631 ASELA = 0.5D0*(ASELA1+ASELA2)
21634 IF (IDX0.EQ.IDX1) THEN
21635 IF (IDX0.EQ.1) THEN
21636 ASTOT = ASIGTO(IDXS,IDX0)
21637 ASELA = ASIGEL(IDXS,IDX0)
21640 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21641 PHOSEL = PHOSTO-PHOSIN
21642 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21643 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21646 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21647 ASTOT = ASIGTO(IDXS,IDX0)+
21648 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21649 ASELA = ASIGEL(IDXS,IDX0)+
21650 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21653 STOT = 10.0D0**ASTOT
21654 SELA = 10.0D0**ASELA
21659 *$ CREATE DT_SIHNAB.FOR
21662 *===sihnab===============================================================*
21664 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21666 **********************************************************************
21667 * Pion 2-nucleon absorption cross sections. *
21668 * (sigma_tot for pi+ d --> p p, pi- d --> n n *
21669 * taken from Ritchie PRC 28 (1983) 926 ) *
21670 * This version dated 18.05.96 is written by S. Roesler *
21671 **********************************************************************
21673 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21675 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21676 PARAMETER (AMPR = 938.0D0,
21686 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21687 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21689 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21690 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21691 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21692 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21693 * approximate 3N-abs., I=1-abs. etc.
21694 SIGABS = SIGABS/0.40D0
21695 * pi0-absorption (rough approximation!!)
21696 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21701 *$ CREATE DT_SIGEMU.FOR
21704 *===sigemu=============================================================*
21706 SUBROUTINE DT_SIGEMU
21708 ************************************************************************
21709 * Combined cross section for target compounds. *
21710 * This version dated 6.4.98 is written by S. Roesler *
21711 ************************************************************************
21713 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21715 PARAMETER ( LINP = 10 ,
21718 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21719 & OHALF=0.5D0,ONE=1.0D0)
21721 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21722 * Glauber formalism: cross sections
21723 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21724 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21725 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21726 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21727 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21728 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21729 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21730 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21731 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21732 & BSLOPE,NEBINI,NQBINI
21733 * emulsion treatment
21734 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21736 * nucleon-nucleon event-generator
21739 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21741 IF (MCGENE.NE.4) THEN
21742 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21743 WRITE(LOUT,'(15X,A)') '-----------------------'
21763 IF (NCOMPO.GT.0) THEN
21765 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21766 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21767 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21768 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21769 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21770 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21771 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21772 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21773 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21774 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21775 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21776 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21777 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21778 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21779 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21780 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21782 ERRTOT = SQRT(ERRTOT)
21783 ERRELA = SQRT(ERRELA)
21784 ERRQEP = SQRT(ERRQEP)
21785 ERRQET = SQRT(ERRQET)
21786 ERRQE2 = SQRT(ERRQE2)
21787 ERRPRO = SQRT(ERRPRO)
21788 ERRDEL = SQRT(ERRDEL)
21789 ERRDQE = SQRT(ERRDQE)
21791 SIGTOT = XSTOT(IE,IQ,1)
21792 SIGELA = XSELA(IE,IQ,1)
21793 SIGQEP = XSQEP(IE,IQ,1)
21794 SIGQET = XSQET(IE,IQ,1)
21795 SIGQE2 = XSQE2(IE,IQ,1)
21796 SIGPRO = XSPRO(IE,IQ,1)
21797 SIGDEL = XSDEL(IE,IQ,1)
21798 SIGDQE = XSDQE(IE,IQ,1)
21799 ERRTOT = XETOT(IE,IQ,1)
21800 ERRELA = XEELA(IE,IQ,1)
21801 ERRQEP = XEQEP(IE,IQ,1)
21802 ERRQET = XEQET(IE,IQ,1)
21803 ERRQE2 = XEQE2(IE,IQ,1)
21804 ERRPRO = XEPRO(IE,IQ,1)
21805 ERRDEL = XEDEL(IE,IQ,1)
21806 ERRDQE = XEDQE(IE,IQ,1)
21808 IF (MCGENE.NE.4) THEN
21809 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21810 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21811 WRITE(LOUT,1001) SIGTOT,ERRTOT
21812 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21813 WRITE(LOUT,1002) SIGELA,ERRELA
21814 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21815 WRITE(LOUT,1003) SIGQEP,ERRQEP
21816 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21818 WRITE(LOUT,1004) SIGQET,ERRQET
21819 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21821 WRITE(LOUT,1005) SIGQE2,ERRQE2
21822 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21823 & ' +-',F11.5,' mb')
21824 WRITE(LOUT,1006) SIGPRO,ERRPRO
21825 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21826 WRITE(LOUT,1007) SIGDEL,ERRDEL
21827 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21828 WRITE(LOUT,1008) SIGDQE,ERRDQE
21829 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21838 *$ CREATE DT_SIGGA.FOR
21841 *===sigga==============================================================*
21843 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21845 ************************************************************************
21846 * Total/inelastic photon-nucleus cross sections. *
21847 * !!!! Overwrites SHMAKI-initialization. Do not use it during *
21848 * production runs !!!! *
21849 * This version dated 27.03.96 is written by S. Roesler *
21850 ************************************************************************
21852 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21854 PARAMETER ( LINP = 10 ,
21857 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21858 & OHALF=0.5D0,ONE=1.0D0)
21859 PARAMETER (AMPROT = 0.938D0)
21861 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21862 * Glauber formalism: cross sections
21863 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21864 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21865 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21866 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21867 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21868 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21869 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21870 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21871 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21872 & BSLOPE,NEBINI,NQBINI
21879 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21880 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21881 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21882 STOT = XSTOT(1,1,1)
21883 ETOT = XETOT(1,1,1)
21890 *$ CREATE DT_SIGGAT.FOR
21893 *===siggat=============================================================*
21895 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21897 ************************************************************************
21898 * Total/inelastic photon-nucleus cross sections. *
21899 * Uses pre-tabulated cross section. *
21900 * This version dated 29.07.96 is written by S. Roesler *
21901 ************************************************************************
21903 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21905 PARAMETER ( LINP = 10 ,
21908 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21909 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21911 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21912 * Glauber formalism: cross sections
21913 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21914 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21915 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21916 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21917 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21918 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21919 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21920 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21921 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21922 & BSLOPE,NEBINI,NQBINI
21928 IF (NEBINI.GT.1) THEN
21929 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21933 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21935 IF (ECMI.LT.ECMNN(I)) THEN
21938 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21948 IF (NQBINI.GT.1) THEN
21949 IF (Q2I.GE.Q2G(NQBINI)) THEN
21953 ELSEIF (Q2I.GT.Q2G(1)) THEN
21955 IF (Q2I.LT.Q2G(I)) THEN
21958 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21959 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21960 C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21968 STOT = XSTOT(I1,J1,NTARG)+
21969 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21970 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21971 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21972 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21977 *$ CREATE DT_SANO.FOR
21980 *===sigano=============================================================*
21982 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21984 ************************************************************************
21985 * This version dated 31.07.96 is written by S. Roesler *
21986 ************************************************************************
21988 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21990 PARAMETER ( LINP = 10 ,
21993 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21994 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21997 * VDM parameter for photon-nucleus interactions
21998 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21999 * properties of interacting particles
22000 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
22002 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
22004 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
22005 & 0.100D+04,0.200D+04,0.500D+04
22007 * fixed cut (3 GeV/c)
22009 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
22010 & 0.062D+00,0.054D+00,0.042D+00
22013 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
22014 & 3.3086D-01,7.6255D-01,2.1319D+00
22016 * running cut (based on obsolete Phojet-caluclations, bugs..)
22018 C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
22019 C & 0.167E+00,0.150E+00,0.131E+00
22022 C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22023 C & 2.5736E-01,4.5593E-01,8.2550E-01
22027 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22031 IF (ECM.GE.ECMANO(NE)) THEN
22034 ELSEIF (ECM.GT.ECMANO(1)) THEN
22036 IF (ECM.LT.ECMANO(IE)) THEN
22039 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22045 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22046 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22047 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22048 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22054 *$ CREATE DT_SIGGP.FOR
22057 *===siggp==============================================================*
22059 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22061 ************************************************************************
22062 * Total/inelastic photon-nucleon cross sections. *
22063 * This version dated 30.04.96 is written by S. Roesler *
22064 ************************************************************************
22066 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22068 PARAMETER ( LINP = 10 ,
22071 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22072 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22074 & GEV2MB = 0.38938D0,
22075 & ALPHEM = ONE/137.0D0)
22077 * particle properties (BAMJET index convention)
22079 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22080 & IICH(210),IIBAR(210),K1(210),K2(210)
22081 * VDM parameter for photon-nucleus interactions
22082 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22085 C CHARACTER*8 MDLNA
22086 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22087 C PARAMETER (IEETAB=10)
22088 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22090 C model switches and parameters
22092 INTEGER ISWMDL,IPAMDL
22093 DOUBLE PRECISION PARMDL
22094 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22095 C energy-interpolation table
22097 PARAMETER ( IEETA2 = 20 )
22099 DOUBLE PRECISION SIGTAB,SIGECM
22100 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22103 C PARAMETER (NPOINT=80)
22104 PARAMETER (NPOINT=16)
22105 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22112 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22113 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22117 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22119 X = Q2/(W2+Q2-AAM(1)**2)
22121 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22122 X = Q2/(W2+Q2-AAM(1)**2)
22123 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22124 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22125 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22126 W2 = Q2*(ONE-X)/X+AAM(1)**2
22128 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22133 IF (MODEGA.EQ.1) THEN
22135 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22138 C ALLMF2 = PHO_ALLM97(Q2,W)
22139 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22140 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22143 ELSEIF (MODEGA.EQ.2) THEN
22144 IF (INTRGE(1).EQ.1) THEN
22145 AMLO2 = (3.0D0*AAM(13))**2
22146 ELSEIF (INTRGE(1).EQ.2) THEN
22151 IF (INTRGE(2).EQ.1) THEN
22153 ELSEIF (INTRGE(2).EQ.2) THEN
22158 AMHI20 = (ECM-AAM(1))**2
22159 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22160 XAMLO = LOG( AMLO2+Q2 )
22161 XAMHI = LOG( AMHI2+Q2 )
22163 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22165 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22169 AM2 = EXP(ABSZX(J))-Q2
22170 IF (AM2.LT.16.0D0) THEN
22172 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22177 C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22178 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22179 & * (ONE+EPSPOL*Q2/AM2)
22180 SUM = SUM+WEIGHT(J)*FAC
22183 SDIR = DT_SIGVP(X,Q2)
22184 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22185 SDIR = SDIR/(0.588D0+RL2+Q2)
22186 C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22187 ELSEIF (MODEGA.EQ.3) THEN
22188 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22189 ELSEIF (MODEGA.EQ.4) THEN
22190 * load cross sections from PHOJET interpolation table
22192 IF(ECM.LE.SIGECM(IP,1)) THEN
22195 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22197 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22203 WRITE(LOUT,'(/1X,A,2E12.3)')
22204 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22209 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22210 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22212 * cross section dependence on photon virtuality
22215 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22216 & /(1.D0+Q2/PARMDL(30+I))**2
22218 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22222 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22223 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22224 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22228 SDIR = SDIR/(FSUP1*FSUP2)
22237 *$ CREATE DT_SIGVEL.FOR
22240 *===sigvel=============================================================*
22242 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22244 ************************************************************************
22245 * Cross section for elastic vector meson production *
22246 * This version dated 10.05.96 is written by S. Roesler *
22247 ************************************************************************
22249 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22251 PARAMETER ( LINP = 10 ,
22254 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22255 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22257 & GEV2MB = 0.38938D0,
22258 & ALPHEM = ONE/137.0D0)
22260 * particle properties (BAMJET index convention)
22262 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22263 & IICH(210),IIBAR(210),K1(210),K2(210)
22264 * VDM parameter for photon-nucleus interactions
22265 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22268 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22269 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22273 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22275 X = Q2/(W2+Q2-AAM(1)**2)
22277 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22278 X = Q2/(W2+Q2-AAM(1)**2)
22279 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22280 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22281 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22282 W2 = Q2*(ONE-X)/X+AAM(1)**2
22284 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22292 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22293 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22295 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22296 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22298 IF (IDXV.EQ.33) THEN
22303 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22305 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
22306 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
22311 *$ CREATE DT_SIGVP.FOR
22314 *===sigvp==============================================================*
22316 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22318 ************************************************************************
22320 ************************************************************************
22322 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22325 PARAMETER ( LINP = 10 ,
22328 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22329 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22331 & GEV2MB = 0.38938D0,
22332 & AMPROT = 0.938D0,
22333 & ALPHEM = ONE/137.0D0)
22334 * VDM parameter for photon-nucleus interactions
22335 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22339 IF (XI.LE.ZERO) X = 0.0001D0
22340 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22342 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22345 IF (MODEGA.EQ.1) THEN
22346 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22349 C ALLMF2 = PHO_ALLM97(Q2,W)
22350 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22351 C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22352 C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22353 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22354 ELSEIF (MODEGA.EQ.4) THEN
22355 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22356 C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22357 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22359 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22366 *$ CREATE DT_RRM2.FOR
22369 *===RRM2===============================================================*
22371 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22373 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22375 PARAMETER ( LINP = 10 ,
22378 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22379 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22381 & GEV2MB = 0.38938D0)
22383 * particle properties (BAMJET index convention)
22385 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22386 & IICH(210),IIBAR(210),K1(210),K2(210)
22387 * VDM parameter for photon-nucleus interactions
22388 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22390 S = Q2*(ONE-X)/X+AAM(1)**2
22393 IF (INTRGE(1).EQ.1) THEN
22394 AMLO2 = (3.0D0*AAM(13))**2
22395 ELSEIF (INTRGE(1).EQ.2) THEN
22400 IF (INTRGE(2).EQ.1) THEN
22402 ELSEIF (INTRGE(2).EQ.2) THEN
22407 AMHI20 = (ECM-AAM(1))**2
22408 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22412 IF (AMHI2.LE.AM1C2) THEN
22413 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22414 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22415 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22416 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22418 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22419 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22420 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22426 *$ CREATE DT_RM2.FOR
22429 *===RM2================================================================*
22431 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22433 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22435 PARAMETER ( LINP = 10 ,
22438 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22439 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22441 & GEV2MB = 0.38938D0)
22442 * VDM parameter for photon-nucleus interactions
22443 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22445 IF (RL2.LE.ZERO) THEN
22446 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22447 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22448 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22450 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22451 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22452 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22453 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22455 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22456 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22462 *$ CREATE DT_SAM2.FOR
22465 *===SAM2===============================================================*
22467 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22469 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22471 PARAMETER ( LINP = 10 ,
22474 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22475 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22476 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22478 & GEV2MB = 0.38938D0)
22480 * particle properties (BAMJET index convention)
22482 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22483 & IICH(210),IIBAR(210),K1(210),K2(210)
22484 * VDM parameter for photon-nucleus interactions
22485 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22488 IF (INTRGE(1).EQ.1) THEN
22489 AMLO2 = (3.0D0*AAM(13))**2
22490 ELSEIF (INTRGE(1).EQ.2) THEN
22495 IF (INTRGE(2).EQ.1) THEN
22497 ELSEIF (INTRGE(2).EQ.2) THEN
22502 AMHI20 = (ECM-AAM(1))**2
22503 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22507 YLO = LOG(AMLO2+Q2)
22508 YC1 = LOG(AM1C2+Q2)
22509 YC2 = LOG(AM2C2+Q2)
22510 YHI = LOG(AMHI2+Q2)
22511 IF (AMHI2.LE.AM1C2) THEN
22513 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22520 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22521 IF (YSAM2.LE.YC1) THEN
22523 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22528 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22529 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22530 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22532 DT_SAM2 = EXP(YSAM2)-Q2
22537 *$ CREATE DT_CKMT.FOR
22540 *===ckmt===============================================================*
22542 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22545 ************************************************************************
22546 * This version dated 31.01.96 is written by S. Roesler *
22547 ************************************************************************
22549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22551 PARAMETER ( LINP = 10 ,
22554 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22556 PARAMETER (Q02 = 2.0D0,
22560 DIMENSION PD(-6:6),SEA(3),VAL(2)
22562 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22563 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22564 ADQ2 = LOG10(Q12)-LOG10(Q02)
22565 F2P = (F2Q1-F2Q0)/ADQ2
22566 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22567 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22568 F2PP = (F2PQ1-F2PQ0)/ADQ2
22569 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22571 Q2 = MAX(SCALE**2.0D0,TINY10)
22572 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22573 IF (Q2.LT.Q02) THEN
22574 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22585 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22598 C USEA = USEA*SMOOTH
22599 C DSEA = DSEA*SMOOTH
22609 *$ CREATE DT_CKMTX.FOR
22611 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22612 C**********************************************************************
22614 C PDF based on Regge theory, evolved with .... by ....
22616 C input: IPAR 2212 proton (not installed)
22620 C output: PD(-6:6) x*f(x) parton distribution functions
22621 C (PDFLIB convention: d = PD(1), u = PD(2) )
22623 C**********************************************************************
22626 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22627 PARAMETER ( LINP = 10 ,
22635 C QCD lambda for evolution
22638 C Q0**2 for evolution
22642 C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22643 C q(6)=x*charm, q(7)=x*gluon
22647 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22649 IF(IPAR.EQ.2212) THEN
22650 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22651 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22652 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22653 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22654 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22655 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22656 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22657 C ELSEIF (IPAR.EQ.45) THEN
22658 C CALL CKMTPO(1,0,XX,SB,QQ(1))
22659 C CALL CKMTPO(2,0,XX,SB,QQ(2))
22660 C CALL CKMTPO(3,0,XX,SB,QQ(3))
22661 C CALL CKMTPO(4,0,XX,SB,QQ(4))
22662 C CALL CKMTPO(5,0,XX,SB,QQ(5))
22663 C CALL CKMTPO(8,0,XX,SB,QQ(6))
22664 C CALL CKMTPO(7,0,XX,SB,QQ(7))
22665 ELSEIF (IPAR.EQ.100) THEN
22666 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22667 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22668 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22669 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22670 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22671 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22672 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22674 WRITE(LOUT,'(1X,A,I4,A)')
22675 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22681 PD(-4) = DBLE(QQ(6))
22682 PD(-3) = DBLE(QQ(3))
22683 PD(-2) = DBLE(QQ(4))
22684 PD(-1) = DBLE(QQ(5))
22685 PD(0) = DBLE(QQ(7))
22686 PD(1) = DBLE(QQ(2))
22687 PD(2) = DBLE(QQ(1))
22688 PD(3) = DBLE(QQ(3))
22689 PD(4) = DBLE(QQ(6))
22692 IF(IPAR.EQ.45) THEN
22693 CDN = (PD(1)-PD(-1))/2.D0
22694 CUP = (PD(2)-PD(-2))/2.D0
22695 PD(-1) = PD(-1) + CDN
22696 PD(-2) = PD(-2) + CUP
22700 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22701 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22702 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22706 *$ CREATE DT_PDF0.FOR
22709 *===pdf0===============================================================*
22711 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22713 ************************************************************************
22714 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22715 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22716 * IPAR = 2212 proton *
22718 * This version dated 31.01.96 is written by S. Roesler *
22719 ************************************************************************
22721 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22723 PARAMETER ( LINP = 10 ,
22726 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22735 & DELTA0 = 0.07684D0,
22740 & ALPHAR = 0.415D0,
22744 PARAMETER (NPOINT=16)
22745 C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22746 DIMENSION SEA(3),VAL(2)
22748 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22749 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22751 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22752 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22753 SEA(1) = 0.75D0*SEA0
22756 VAL(1) = 9.0D0/4.0D0*VALU0
22757 VAL(2) = 9.0D0*VALD0
22758 GLU0 = SEA(1)/(1.0D0-X)
22759 F2 = SEA0+VALU0+VALD0
22760 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22761 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22762 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22763 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22764 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22768 C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22770 C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22775 C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22776 C VALU0 = 9.0D0/4.0D0*VALU0
22777 C VALD0 = 9.0D0*VALD0
22778 C SEA0 = 0.75D0*SEA0
22779 C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22780 C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22782 C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22784 WRITE(LOUT,'(1X,A,I4,A)')
22785 & 'PDF0: IPAR =',IPAR,' not implemented!'
22792 *$ CREATE DT_CKMTQ0.FOR
22795 *===ckmtq0=============================================================*
22797 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22799 ************************************************************************
22800 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22801 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22802 * IPAR = 2212 proton *
22804 * This version dated 31.01.96 is written by S. Roesler *
22805 ************************************************************************
22807 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22809 PARAMETER ( LINP = 10 ,
22812 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22821 & DELTA0 = 0.07684D0,
22826 & ALPHAR = 0.415D0,
22830 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22831 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22833 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22834 IF (IPAR.EQ.2212) THEN
22841 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22842 & (Q2/(Q2+A))**(1.0D0+DELTA)
22843 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22844 & (Q2/(Q2+B))**(ALPHAR)
22845 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22846 & (Q2/(Q2+B))**(ALPHAR)
22848 WRITE(LOUT,'(1X,A,I4,A)')
22849 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22857 *$ CREATE DT_CKMTDE.FOR
22859 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22861 C**********************************************************************
22863 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22865 C This version by S. Roesler, 30.01.96
22866 C**********************************************************************
22869 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22870 EQUIVALENCE (GF(1,1,1),DL(1))
22873 DATA (DL(K),K= 1, 85) /
22874 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22875 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22876 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22877 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22878 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22879 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22880 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22881 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22882 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22883 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22884 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22885 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22886 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22887 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22888 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22889 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22890 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22891 DATA (DL(K),K= 86, 170) /
22892 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22893 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22894 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22895 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22896 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22897 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22898 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22899 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22900 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22901 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22902 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22903 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22904 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22905 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22906 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22907 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22908 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22909 DATA (DL(K),K= 171, 255) /
22910 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22911 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22912 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22913 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22914 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22915 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22916 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22917 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22918 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22919 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22920 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22921 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22922 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22923 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22924 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22925 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22926 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22927 DATA (DL(K),K= 256, 340) /
22928 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22929 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22930 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22931 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22932 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22933 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22934 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22935 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22936 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22937 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22938 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22939 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22940 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22941 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22942 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22943 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22944 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22945 DATA (DL(K),K= 341, 425) /
22946 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22947 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22948 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22949 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22950 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22951 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22952 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22953 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22954 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22955 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22956 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22957 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22958 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22959 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22960 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22961 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22962 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22963 DATA (DL(K),K= 426, 510) /
22964 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22965 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22966 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22967 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22968 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22969 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22970 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22971 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22972 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22973 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22974 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22975 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22976 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22977 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22978 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22979 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22980 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22981 DATA (DL(K),K= 511, 595) /
22982 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22983 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22984 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22985 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22986 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22987 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22988 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22989 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22990 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22991 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22992 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22993 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22994 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22995 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22996 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22997 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22998 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22999 DATA (DL(K),K= 596, 680) /
23000 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
23001 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23002 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23003 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23004 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23005 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23006 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23007 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23008 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23009 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23010 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
23011 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
23012 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
23013 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
23014 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
23015 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
23016 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
23017 DATA (DL(K),K= 681, 765) /
23018 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
23019 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
23020 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
23021 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
23022 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23023 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23024 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23025 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23026 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23027 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23028 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23029 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23030 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23031 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23032 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23033 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23034 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23035 DATA (DL(K),K= 766, 850) /
23036 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23037 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23038 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23039 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23040 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23041 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23042 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23043 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23044 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23045 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23046 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23047 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23048 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23049 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23050 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23051 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23052 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23053 DATA (DL(K),K= 851, 935) /
23054 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23055 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23056 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23057 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23058 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23059 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23060 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23061 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23062 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23063 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23064 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23065 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23066 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23067 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
23068 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23069 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23070 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23071 DATA (DL(K),K= 936, 1020) /
23072 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23073 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23074 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23075 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23076 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23077 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23078 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23079 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23080 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23081 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23082 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23083 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23084 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23085 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23086 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23087 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23088 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23089 DATA (DL(K),K= 1021, 1105) /
23090 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23091 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23092 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23093 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23094 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23095 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23096 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23097 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23098 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23099 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23100 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23101 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
23102 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23103 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23104 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23105 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23106 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23107 DATA (DL(K),K= 1106, 1190) /
23108 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23109 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23110 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23111 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23112 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23113 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23114 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23115 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23116 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23117 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23118 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23119 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23120 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23121 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23122 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23123 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23124 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23125 DATA (DL(K),K= 1191, 1275) /
23126 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23127 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23128 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23129 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23130 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23131 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23132 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23133 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23134 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23135 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
23136 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23137 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23138 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23139 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23140 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23141 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23142 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23143 DATA (DL(K),K= 1276, 1360) /
23144 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23145 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23146 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23147 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23148 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23149 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23150 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23151 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23152 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23153 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23154 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23155 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23156 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23157 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23158 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23159 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23160 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23161 DATA (DL(K),K= 1361, 1445) /
23162 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23163 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23164 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23165 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23166 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23167 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23168 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23169 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
23170 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23171 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23172 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23173 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23174 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23175 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23176 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23177 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23178 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23179 DATA (DL(K),K= 1446, 1530) /
23180 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23181 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23182 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23183 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23184 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23185 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23186 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23187 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23188 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23189 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23190 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23191 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23192 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23193 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23194 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23195 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23196 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23197 DATA (DL(K),K= 1531, 1615) /
23198 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23199 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23200 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23201 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23202 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23203 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
23204 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23205 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23206 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23207 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23208 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23209 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23210 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23211 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23212 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23213 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23214 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23215 DATA (DL(K),K= 1616, 1700) /
23216 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23217 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23218 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23219 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23220 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23221 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23222 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23223 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23224 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23225 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23226 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23227 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23228 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23229 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23230 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23231 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23232 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23233 DATA (DL(K),K= 1701, 1785) /
23234 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23235 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23236 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23237 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
23238 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23239 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23240 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23241 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23242 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23243 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23244 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23245 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23246 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23247 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23248 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23249 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23250 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23251 DATA (DL(K),K= 1786, 1870) /
23252 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23253 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23254 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23255 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23256 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23257 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23258 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23259 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23260 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23261 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23262 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23263 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23264 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23265 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23266 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23267 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23268 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23269 DATA (DL(K),K= 1871, 1955) /
23270 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23271 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
23272 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23273 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23274 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23275 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23276 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23277 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23278 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23279 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23280 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23281 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23282 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23283 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23284 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23285 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23286 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23287 DATA (DL(K),K= 1956, 2040) /
23288 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23289 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23290 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23291 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23292 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23293 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23294 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23295 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23296 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23297 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23298 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23299 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23300 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23301 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23302 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23303 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23304 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23305 DATA (DL(K),K= 2041, 2125) /
23306 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23307 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23308 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23309 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23310 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23311 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23312 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23313 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23314 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23315 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23316 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23317 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23318 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23319 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23320 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23321 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23322 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23323 DATA (DL(K),K= 2126, 2210) /
23324 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23325 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23326 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23327 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23328 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23329 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23330 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23331 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23332 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23333 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23334 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23335 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23336 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23337 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23338 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23339 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23340 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23341 DATA (DL(K),K= 2211, 2295) /
23342 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23343 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23344 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23345 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23346 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23347 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23348 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23349 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23350 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23351 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23352 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23353 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23354 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23355 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23356 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23357 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23358 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23359 DATA (DL(K),K= 2296, 2380) /
23360 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23361 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23362 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23363 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23364 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23365 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23366 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23367 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23368 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23369 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23370 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23371 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23372 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23373 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23374 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23375 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23376 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23377 DATA (DL(K),K= 2381, 2465) /
23378 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23379 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23380 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23381 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23382 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23383 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23384 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23385 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23386 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23387 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23388 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23389 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23390 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23391 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23392 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23393 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23394 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23395 DATA (DL(K),K= 2466, 2550) /
23396 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23397 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23398 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23399 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23400 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23401 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23402 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23403 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23404 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23405 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23406 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23407 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23408 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23409 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23410 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23411 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23412 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23413 DATA (DL(K),K= 2551, 2635) /
23414 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23415 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23416 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23417 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23418 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23419 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23420 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23421 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23422 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23423 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23424 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23425 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23426 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23427 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23428 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23429 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23430 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23431 DATA (DL(K),K= 2636, 2720) /
23432 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23433 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23434 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23435 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23436 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23437 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23438 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23439 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23440 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23441 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23442 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23443 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23444 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23445 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23446 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23447 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23448 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23449 DATA (DL(K),K= 2721, 2805) /
23450 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23451 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23452 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23453 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23454 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23455 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23456 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23457 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23458 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23459 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23460 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23461 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23462 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23463 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23464 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23465 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23466 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23467 DATA (DL(K),K= 2806, 2890) /
23468 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23469 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23470 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23471 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23472 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23473 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23474 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23475 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23476 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23477 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23478 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23479 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23480 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23481 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23482 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23483 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23484 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23485 DATA (DL(K),K= 2891, 2975) /
23486 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23487 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23488 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23489 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23490 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23491 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23492 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23493 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23494 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23495 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23496 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23497 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23498 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23499 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23500 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23501 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23502 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23503 DATA (DL(K),K= 2976, 3060) /
23504 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23505 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23506 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23507 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23508 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23509 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23510 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23511 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23512 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23513 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23514 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23515 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23516 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23517 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23518 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23519 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23520 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23521 DATA (DL(K),K= 3061, 3145) /
23522 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23523 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23524 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23525 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23526 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23527 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23528 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23529 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23530 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23531 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23532 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23533 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23534 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23535 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23536 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23537 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23538 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23539 DATA (DL(K),K= 3146, 3230) /
23540 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23541 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23542 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23543 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23544 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23545 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23546 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23547 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23548 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23549 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23550 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23551 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23552 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23553 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23554 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23555 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23556 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23557 DATA (DL(K),K= 3231, 3315) /
23558 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23559 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23560 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23561 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23562 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23563 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23564 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23565 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23566 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23567 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23568 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23569 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23570 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23571 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23572 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23573 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23574 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23575 DATA (DL(K),K= 3316, 3400) /
23576 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23577 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23578 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23579 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23580 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23581 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23582 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23583 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23584 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23585 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23586 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23587 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23588 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23589 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23590 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23591 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23592 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23593 DATA (DL(K),K= 3401, 3485) /
23594 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23595 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23596 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23597 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23598 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23599 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23600 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23601 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23602 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23603 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23604 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23605 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23606 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23607 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23608 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23609 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23610 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23611 DATA (DL(K),K= 3486, 3570) /
23612 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23613 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23614 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23615 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23616 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23617 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23618 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23619 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23620 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23621 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23622 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23623 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23624 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23625 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23626 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23627 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23628 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23629 DATA (DL(K),K= 3571, 3655) /
23630 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23631 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23632 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23633 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23634 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23635 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23636 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23637 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23638 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23639 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23640 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23641 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23642 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23643 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23644 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23645 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23646 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23647 DATA (DL(K),K= 3656, 3740) /
23648 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23649 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23650 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23651 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23652 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23653 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23654 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23655 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23656 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23657 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23658 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23659 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23660 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23661 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23662 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23663 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23664 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23665 DATA (DL(K),K= 3741, 3825) /
23666 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23667 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23668 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23669 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23670 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23671 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23672 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23673 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23674 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23675 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23676 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23677 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23678 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23679 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23680 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23681 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23682 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23683 DATA (DL(K),K= 3826, 3910) /
23684 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23685 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23686 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23687 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23688 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23689 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23690 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23691 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23692 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23693 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23694 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23695 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23696 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23697 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23698 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23699 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23700 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23701 DATA (DL(K),K= 3911, 3995) /
23702 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23703 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23704 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23705 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23706 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23707 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23708 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23709 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23710 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23711 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23712 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23713 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23714 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23715 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23716 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23717 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23718 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23719 DATA (DL(K),K= 3996, 4000) /
23720 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23723 IF (X.GT.0.9985) RETURN
23724 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23730 F1(L) = GF(I,IS,KL)
23731 F2(L) = GF(I,IS1,KL)
23733 A1 = DT_CKMTFF(X,F1)
23734 A2 = DT_CKMTFF(X,F2)
23739 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23746 *$ CREATE DT_CKMTPR.FOR
23748 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23750 C**********************************************************************
23752 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23754 C This version by S. Roesler, 31.01.96
23755 C**********************************************************************
23758 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23759 EQUIVALENCE (GF(1,1,1),DL(1))
23762 DATA (DL(K),K= 1, 85) /
23763 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23764 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23765 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23766 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23767 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23768 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23769 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23770 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23771 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23772 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23773 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23774 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23775 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23776 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23777 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23778 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23779 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23780 DATA (DL(K),K= 86, 170) /
23781 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23782 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23783 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23784 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23785 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23786 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23787 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23788 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23789 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23790 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23791 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23792 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23793 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23794 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23795 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23796 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23797 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23798 DATA (DL(K),K= 171, 255) /
23799 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23800 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23801 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23802 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23803 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23804 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23805 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23806 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23807 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23808 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23809 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23810 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23811 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23812 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23813 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23814 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23815 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23816 DATA (DL(K),K= 256, 340) /
23817 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23818 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23819 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23820 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23821 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23822 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23823 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23824 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23825 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23826 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23827 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23828 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23829 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23830 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23831 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23832 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23833 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23834 DATA (DL(K),K= 341, 425) /
23835 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23836 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23837 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23838 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23839 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23840 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23841 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23842 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23843 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23844 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23845 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23846 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23847 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23848 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23849 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23850 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23851 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23852 DATA (DL(K),K= 426, 510) /
23853 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23854 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23855 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23856 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23857 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23858 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23859 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23860 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23861 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23862 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23863 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23864 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23865 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23866 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23867 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23868 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23869 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23870 DATA (DL(K),K= 511, 595) /
23871 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23872 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23873 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23874 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23875 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23876 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23877 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23878 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23879 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23880 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23881 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23882 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23883 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23884 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23885 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23886 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23887 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23888 DATA (DL(K),K= 596, 680) /
23889 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23890 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23891 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23892 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23893 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23894 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23895 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23896 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23897 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23898 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23899 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23900 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23901 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23902 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23903 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23904 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23905 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23906 DATA (DL(K),K= 681, 765) /
23907 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23908 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23909 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23910 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23911 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23912 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23913 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23914 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23915 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23916 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23917 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23918 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23919 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23920 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23921 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23922 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23923 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23924 DATA (DL(K),K= 766, 850) /
23925 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23926 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23927 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23928 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23929 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23930 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23931 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23932 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23933 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23934 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23935 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23936 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23937 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23938 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23939 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23940 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23941 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23942 DATA (DL(K),K= 851, 935) /
23943 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23944 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23945 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23946 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23947 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23948 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23949 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23950 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23951 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23952 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23953 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23954 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23955 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23956 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23957 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23958 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23959 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23960 DATA (DL(K),K= 936, 1020) /
23961 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23962 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23963 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23964 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23965 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23966 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23967 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23968 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23969 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23970 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23971 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23972 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23973 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23974 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23975 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23976 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23977 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23978 DATA (DL(K),K= 1021, 1105) /
23979 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23980 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23981 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23982 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23983 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23984 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23985 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23986 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23987 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23988 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23989 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23990 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23991 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23992 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23993 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23994 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23995 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23996 DATA (DL(K),K= 1106, 1190) /
23997 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23998 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23999 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24000 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
24001 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
24002 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
24003 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
24004 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
24005 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
24006 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
24007 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
24008 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
24009 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
24010 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
24011 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
24012 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
24013 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
24014 DATA (DL(K),K= 1191, 1275) /
24015 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
24016 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
24017 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
24018 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
24019 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
24020 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
24021 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
24022 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24023 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24024 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24025 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24026 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24027 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24028 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24029 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24030 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24031 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24032 DATA (DL(K),K= 1276, 1360) /
24033 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24034 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24035 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24036 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24037 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24038 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24039 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24040 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24041 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24042 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24043 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24044 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24045 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24046 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24047 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24048 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24049 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24050 DATA (DL(K),K= 1361, 1445) /
24051 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24052 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24053 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24054 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24055 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24056 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24057 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24058 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24059 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24060 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24061 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24062 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24063 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24064 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24065 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24066 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24067 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24068 DATA (DL(K),K= 1446, 1530) /
24069 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24070 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24071 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24072 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24073 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24074 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24075 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24076 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24077 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24078 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24079 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24080 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24081 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24082 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24083 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24084 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24085 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24086 DATA (DL(K),K= 1531, 1615) /
24087 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24088 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24089 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24090 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24091 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24092 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24093 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24094 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24095 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24096 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24097 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24098 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24099 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24100 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24101 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24102 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24103 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24104 DATA (DL(K),K= 1616, 1700) /
24105 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24106 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24107 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24108 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24109 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24110 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24111 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24112 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24113 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24114 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24115 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24116 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24117 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24118 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24119 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24120 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24121 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24122 DATA (DL(K),K= 1701, 1785) /
24123 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24124 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24125 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24126 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24127 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24128 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24129 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24130 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24131 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24132 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24133 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24134 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24135 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24136 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24137 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24138 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24139 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24140 DATA (DL(K),K= 1786, 1870) /
24141 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24142 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24143 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24144 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24145 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24146 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24147 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24148 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24149 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24150 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24151 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24152 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24153 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24154 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24155 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24156 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24157 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24158 DATA (DL(K),K= 1871, 1955) /
24159 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24160 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24161 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24162 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24163 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24164 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24165 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24166 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24167 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24168 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24169 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24170 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24171 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24172 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24173 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24174 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24175 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24176 DATA (DL(K),K= 1956, 2040) /
24177 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24178 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24179 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24180 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24181 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24182 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24183 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24184 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24185 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24186 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24187 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24188 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24189 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24190 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24191 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24192 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24193 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24194 DATA (DL(K),K= 2041, 2125) /
24195 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24196 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24197 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24198 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24199 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24200 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24201 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24202 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24203 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24204 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24205 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24206 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24207 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24208 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24209 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24210 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24211 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24212 DATA (DL(K),K= 2126, 2210) /
24213 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24214 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24215 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24216 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24217 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24218 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24219 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24220 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24221 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24222 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24223 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24224 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24225 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24226 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24227 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24228 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24229 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24230 DATA (DL(K),K= 2211, 2295) /
24231 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24232 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24233 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24234 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24235 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24236 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24237 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24238 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24239 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24240 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24241 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24242 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24243 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24244 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24245 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24246 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24247 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24248 DATA (DL(K),K= 2296, 2380) /
24249 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24250 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24251 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24252 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24253 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24254 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24255 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24256 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24257 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24258 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24259 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24260 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24261 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24262 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24263 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24264 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24265 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24266 DATA (DL(K),K= 2381, 2465) /
24267 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24268 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24269 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24270 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24271 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24272 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24273 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24274 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24275 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24276 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24277 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24278 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24279 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24280 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24281 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24282 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24283 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24284 DATA (DL(K),K= 2466, 2550) /
24285 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24286 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24287 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24288 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24289 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24290 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24291 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24292 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24293 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24294 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24295 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24296 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24297 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24298 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24299 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24300 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24301 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24302 DATA (DL(K),K= 2551, 2635) /
24303 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24304 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24305 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24306 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24307 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24308 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24309 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24310 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24311 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24312 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24313 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24314 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24315 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24316 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24317 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24318 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24319 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24320 DATA (DL(K),K= 2636, 2720) /
24321 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24322 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24323 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24324 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24325 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24326 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24327 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24328 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24329 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24330 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24331 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24332 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24333 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24334 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24335 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24336 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24337 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24338 DATA (DL(K),K= 2721, 2805) /
24339 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24340 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24341 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24342 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24343 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24344 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24345 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24346 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24347 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24348 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24349 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24350 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24351 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24352 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24353 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24354 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24355 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24356 DATA (DL(K),K= 2806, 2890) /
24357 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24358 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24359 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24360 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24361 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24362 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24363 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24364 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24365 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24366 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24367 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24368 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24369 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24370 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24371 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24372 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24373 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24374 DATA (DL(K),K= 2891, 2975) /
24375 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24376 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24377 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24378 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24379 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24380 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24381 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24382 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24383 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24384 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24385 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24386 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24387 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24388 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24389 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24390 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24391 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24392 DATA (DL(K),K= 2976, 3060) /
24393 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24394 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24395 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24396 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24397 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24398 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24399 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24400 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24401 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24402 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24403 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24404 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24405 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24406 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24407 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24408 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24409 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24410 DATA (DL(K),K= 3061, 3145) /
24411 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24412 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24413 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24414 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24415 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24416 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24417 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24418 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24419 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24420 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24421 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24422 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24423 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24424 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24425 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24426 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24427 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24428 DATA (DL(K),K= 3146, 3230) /
24429 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24430 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24431 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24432 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24433 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24434 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24435 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24436 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24437 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24438 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24439 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24440 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24441 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24442 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24443 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24444 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24445 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24446 DATA (DL(K),K= 3231, 3315) /
24447 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24448 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24449 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24450 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24451 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24452 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24453 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24454 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24455 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24456 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24457 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24458 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24459 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24460 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24461 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24462 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24463 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24464 DATA (DL(K),K= 3316, 3400) /
24465 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24466 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24467 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24468 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24469 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24470 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24471 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24472 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24473 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24474 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24475 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24476 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24477 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24478 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24479 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24480 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24481 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24482 DATA (DL(K),K= 3401, 3485) /
24483 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24484 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24485 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24486 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24487 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24488 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24489 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24490 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24491 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24492 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24493 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24494 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24495 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24496 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24497 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24498 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24499 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24500 DATA (DL(K),K= 3486, 3570) /
24501 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24502 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24503 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24504 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24505 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24506 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24507 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24508 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24509 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24510 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24511 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24512 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24513 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24514 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24515 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24516 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24517 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24518 DATA (DL(K),K= 3571, 3655) /
24519 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24520 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24521 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24522 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24523 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24524 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24525 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24526 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24527 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24528 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24529 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24530 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24531 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24532 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24533 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24534 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24535 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24536 DATA (DL(K),K= 3656, 3740) /
24537 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24538 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24539 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24540 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24541 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24542 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24543 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24544 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24545 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24546 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24547 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24548 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24549 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24550 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24551 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24552 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24553 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24554 DATA (DL(K),K= 3741, 3825) /
24555 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24556 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24557 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24558 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24559 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24560 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24561 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24562 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24563 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24564 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24565 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24566 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24567 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24568 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24569 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24570 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24571 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24572 DATA (DL(K),K= 3826, 3910) /
24573 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24574 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24575 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24576 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24577 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24578 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24579 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24580 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24581 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24582 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24583 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24584 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24585 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24586 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24587 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24588 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24589 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24590 DATA (DL(K),K= 3911, 3995) /
24591 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24592 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24593 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24594 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24595 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24596 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24597 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24598 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24599 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24600 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24601 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24602 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24603 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24604 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24605 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24606 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24607 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24608 DATA (DL(K),K= 3996, 4000) /
24609 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24612 IF (X.GT.0.9985) RETURN
24613 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24619 F1(L) = GF(I,IS,KL)
24620 F2(L) = GF(I,IS1,KL)
24622 A1 = DT_CKMTFF(X,F1)
24623 A2 = DT_CKMTFF(X,F2)
24628 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24634 *$ CREATE DT_CKMTFF.FOR
24636 FUNCTION DT_CKMTFF(X,FVL)
24637 C**********************************************************************
24639 C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24640 C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24641 C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24644 C**********************************************************************
24647 DIMENSION FVL(25),XGRID(25)
24648 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24649 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24653 IF(X.LT.XGRID(I)) GO TO 2
24658 ELSE IF(I.GT.23) THEN
24664 BXI=LOG(1.-XGRID(I))
24666 BXJ=LOG(1.-XGRID(J))
24668 BXK=LOG(1.-XGRID(K))
24669 FI=LOG(ABS(FVL(I)) +1.E-15)
24670 FJ=LOG(ABS(FVL(J)) +1.E-16)
24671 FK=LOG(ABS(FVL(K)) +1.E-17)
24672 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24673 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24675 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24676 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24677 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24679 C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24680 C WRITE(6,2001) X,FVL
24681 C 2001 FORMAT(8E12.4)
24682 C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24684 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24688 *$ CREATE DT_FLUINI.FOR
24691 *===fluini=============================================================*
24693 SUBROUTINE DT_FLUINI
24695 ************************************************************************
24696 * Initialisation of the nucleon-nucleon cross section fluctuation *
24697 * treatment. The original version by J. Ranft. *
24698 * This version dated 21.04.95 is revised by S. Roesler. *
24699 ************************************************************************
24701 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24703 PARAMETER ( LINP = 10 ,
24706 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24708 PARAMETER ( A = 0.1D0,
24714 * n-n cross section fluctuations
24715 PARAMETER (NBINS = 1000)
24716 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24717 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24720 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24729 FLUS = ((X-B)/(OM*B))**N
24730 IF (FLUS.LE.20.0D0) THEN
24731 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24735 FLUSU = FLUSU+FLUSI(I)
24738 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24743 C1001 FORMAT(1X,'FLUCTUATIONS')
24744 C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24747 AF = DBLE(I)*0.001D0
24749 IF (AF.LE.FLUSI(J)) THEN
24750 FLUIXX(I) = FLUIX(J)
24756 FLUIXX(1) = FLUIX(1)
24757 FLUIXX(NBINS) = FLUIX(NBINS)
24762 *$ CREATE DT_SIGTBL.FOR
24765 *===sigtab=============================================================*
24767 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24769 ************************************************************************
24770 * This version dated 18.11.95 is written by S. Roesler *
24771 ************************************************************************
24773 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24775 PARAMETER ( LINP = 10 ,
24779 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24780 & OHALF=0.5D0,ONE=1.0D0)
24781 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24785 * particle properties (BAMJET index convention)
24787 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24788 & IICH(210),IIBAR(210),K1(210),K2(210)
24790 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24791 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24792 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24794 DATA LINIT /.FALSE./
24796 * precalculation and tabulation of elastic cross sections
24797 IF (ABS(MODE).EQ.1) THEN
24799 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24800 PLABLX = LOG10(PLO)
24801 PLABHX = LOG10(PHI)
24802 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24804 PLAB = PLABLX+DBLE(I-1)*DPLAB
24809 C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24810 C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24812 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24813 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24816 IF (MODE.EQ.1) THEN
24817 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24818 & (SIGEN(IDX,I),IDX=1,5)
24819 1000 FORMAT(F5.1,10F7.2)
24822 IF (MODE.EQ.1) CLOSE(LDAT)
24826 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24827 & .AND.(PTOT.LE.PHI) ) THEN
24829 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24830 PLABX = LOG10(PTOT)
24831 IF (PLABX.LE.PLABLX) THEN
24834 ELSEIF (PLABX.GE.PLABHX) THEN
24838 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24841 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24842 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24843 PBIN = PLAB2X-PLAB1X
24844 IF (PBIN.GT.TINY10) THEN
24845 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24850 SIG1 = SIGEP(IDX,I1)
24851 SIG2 = SIGEP(IDX,I2)
24853 SIG1 = SIGEN(IDX,I1)
24854 SIG2 = SIGEN(IDX,I2)
24856 SIGE = SIG1+RATX*(SIG2-SIG1)
24864 *$ CREATE DT_XSTABL.FOR
24867 *===xstabl=============================================================*
24869 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24871 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24873 PARAMETER ( LINP = 10 ,
24876 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24877 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24878 LOGICAL LLAB,LELOG,LQLOG
24880 * particle properties (BAMJET index convention)
24882 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24883 & IICH(210),IIBAR(210),K1(210),K2(210)
24884 * properties of interacting particles
24885 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24886 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24887 * Glauber formalism: cross sections
24888 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24889 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24890 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24891 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24892 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24893 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24894 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24895 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24896 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24897 & BSLOPE,NEBINI,NQBINI
24898 * emulsion treatment
24899 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24904 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24907 IF (ELO.GT.EHI) ELO = EHI
24908 LELOG = WHAT(3).LT.ZERO
24909 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24910 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24914 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24918 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24919 LQLOG = WHAT(6).LT.ZERO
24920 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24921 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24923 AQ2LO = LOG10(Q2LO)
24924 AQ2HI = LOG10(Q2HI)
24925 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24928 IF ( ELO.EQ. EHI) NEBINS = 0
24929 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24931 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24932 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24933 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24934 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24935 & ' A_p = ',I3,' A_t = ',I3,/)
24937 C IF (IJPROJ.NE.7) THEN
24938 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24939 * normalize fractions of emulsion components
24940 IF (NCOMPO.GT.0) THEN
24943 SUMFRA = SUMFRA+EMUFRA(I)
24945 IF (SUMFRA.GT.ZERO) THEN
24947 EMUFRA(I) = EMUFRA(I)/SUMFRA
24952 C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24956 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24958 E = ELO+DBLE(I-1)*DEBINS
24962 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24964 Q2 = Q2LO+DBLE(J-1)*DQBINS
24966 c IF (IJPROJ.NE.7) THEN
24970 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24976 IF (IJPROJ.EQ.7) Q2I = Q2
24977 IF (NCOMPO.GT.0) THEN
24980 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24983 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24984 C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24986 IF (NCOMPO.GT.0) THEN
25005 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
25006 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
25007 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
25008 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
25009 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
25010 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
25011 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
25012 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
25013 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
25014 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
25015 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
25016 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
25017 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
25018 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
25019 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
25020 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
25021 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
25022 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
25024 XPRO1= XPRO1+EMUFRA(IC)*YPRO
25034 WRITE(LOUT,'(8E9.3)')
25035 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25036 C WRITE(LOUT,'(4E9.3)')
25037 C & E,XDEL,XDQE,XDEL+XDQE
25039 WRITE(LOUT,'(11E10.3)')
25041 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25042 & XSQE2(1,1,1),XSPRO(1,1,1),
25043 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25044 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25045 & XSDEL(1,1,1)+XSDQE(1,1,1)
25046 C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25047 C & XSDEL(1,1,1)+XSDQE(1,1,1)
25051 c IF (IT.GT.1) THEN
25052 c IF (IXSQEL.EQ.0) THEN
25053 cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
25054 cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
25055 c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25056 c & STOT,ETOT,SIN,EIN,STOT0)
25057 c IF (IRATIO.EQ.1) THEN
25058 c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25059 cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25060 cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25061 c*!! save cross sections
25066 c STOT = STOT/(DBLE(IT)*STGP)
25067 c SIN = SIN/(DBLE(IT)*SIGP)
25074 c & ' XSTABL: qel. xs. not implemented for nuclei'
25081 c IF (IXSQEL.EQ.0) THEN
25082 c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25085 c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25089 c IF (IT.GT.1) THEN
25090 c IF (IXSQEL.EQ.0) THEN
25091 c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25092 c & STOT,ETOT,SIN,EIN,STOT0)
25093 c IF (IRATIO.EQ.1) THEN
25094 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25095 c*!! save cross sections
25100 c STOT = STOT/(DBLE(IT)*STGP)
25101 c SIN = SIN/(DBLE(IT)*SIGP)
25108 c & ' XSTABL: qel. xs. not implemented for nuclei'
25115 c IF (IXSQEL.EQ.0) THEN
25116 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25119 c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25123 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25124 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25125 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25126 c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25134 *$ CREATE DT_TESTXS.FOR
25137 *===testxs=============================================================*
25139 SUBROUTINE DT_TESTXS
25141 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25144 DIMENSION XSTOT(26,2),XSELA(26,2)
25146 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25147 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25148 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25149 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25154 APLABL = LOG10(PLABL)
25155 APLABH = LOG10(PLABH)
25156 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25158 ADP = APLABL+DBLE(I-1)*ADPLAB
25161 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25162 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25164 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25165 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25166 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25167 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25169 1000 FORMAT(F8.3,26F9.3)
25174 ************************************************************************
25176 * DTUNUC 2.0: library routines *
25177 * processed by S. Roesler, 6.5.95 *
25179 ************************************************************************
25181 * 1) Handling of parton momenta
25182 * SUBROUTINE MASHEL
25183 * SUBROUTINE DFERMI
25185 * 2) Handling of parton flavors and particle indices
25186 * INTEGER FUNCTION IPDG2B
25187 * INTEGER FUNCTION IB2PDG
25188 * INTEGER FUNCTION IQUARK
25189 * INTEGER FUNCTION IBJQUA
25190 * INTEGER FUNCTION ICIHAD
25191 * INTEGER FUNCTION IPDGHA
25192 * INTEGER FUNCTION MCHAD
25193 * SUBROUTINE FLAHAD
25195 * 3) Energy-momentum and quantum number conservation check routines
25198 * SUBROUTINE EVTEMC
25199 * SUBROUTINE EVTFLC
25200 * SUBROUTINE EVTCHG
25202 * 4) Transformations
25204 * SUBROUTINE LTRANS
25206 * SUBROUTINE DALTRA
25207 * SUBROUTINE DTRAFO
25208 * SUBROUTINE STTRAN
25209 * SUBROUTINE MYTRAN
25210 * SUBROUTINE LT2LAO
25211 * SUBROUTINE LT2LAB
25213 * 5) Sampling from distributions
25214 * INTEGER FUNCTION NPOISS
25215 * DOUBLE PRECISION FUNCTION SAMPXB
25216 * DOUBLE PRECISION FUNCTION SAMPEX
25217 * DOUBLE PRECISION FUNCTION SAMSQX
25218 * DOUBLE PRECISION FUNCTION BETREJ
25219 * DOUBLE PRECISION FUNCTION DGAMRN
25220 * DOUBLE PRECISION FUNCTION DBETAR
25221 * SUBROUTINE RANNOR
25223 * SUBROUTINE DSFECF
25226 * 6) Special functions, algorithms and service routines
25227 * DOUBLE PRECISION FUNCTION YLAMB
25230 * SUBROUTINE DT_XTIME
25232 * 7) Random number generator package
25233 * DOUBLE PRECISION FUNCTION DT_RNDM
25234 * SUBROUTINE DT_RNDMST
25235 * SUBROUTINE DT_RNDMIN
25236 * SUBROUTINE DT_RNDMOU
25237 * SUBROUTINE DT_RNDMTE
25239 ************************************************************************
25241 * 1) Handling of parton momenta *
25243 ************************************************************************
25244 *$ CREATE DT_MASHEL.FOR
25247 *===mashel=============================================================*
25249 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25251 ************************************************************************
25253 * rescaling of momenta of two partons to put both *
25256 * input: PA1,PA2 input momentum vectors *
25257 * XM1,2 desired masses of particles afterwards *
25258 * P1,P2 changed momentum vectors *
25260 * The original version is written by R. Engel. *
25261 * This version dated 12.12.94 is modified by S. Roesler. *
25262 ************************************************************************
25264 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25266 PARAMETER ( LINP = 10 ,
25269 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25271 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25275 * Lorentz transformation into system CMS
25280 XPTOT = SQRT(PX**2+PY**2+PZ**2)
25281 XMS = (EE-XPTOT)*(EE+XPTOT)
25282 IF(XMS.LT.(XM1+XM2)**2) THEN
25283 C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25291 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25292 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25295 C SID = SQRT((ONE-COD)*(ONE+COD))
25296 PPT = SQRT(P1(1)**2+P1(2)**2)
25300 IF(PTOT1*SID.GT.TINY10) THEN
25301 COF = P1(1)/(SID*PTOT1)
25302 SIF = P1(2)/(SID*PTOT1)
25303 ANORF = SQRT(COF*COF+SIF*SIF)
25307 * new CM momentum and energies (for masses XM1,XM2)
25308 XM12 = SIGN(XM1**2,XM1)
25309 XM22 = SIGN(XM2**2,XM2)
25311 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25312 EE1 = SQRT(XM12+PCMP**2)
25316 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25317 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25318 & PTOT1,P1(1),P1(2),P1(3),P1(4))
25319 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25320 & PTOT2,P2(1),P2(2),P2(3),P2(4))
25321 * check consistency
25323 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25325 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25327 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25329 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25334 IF (IDEV.NE.0) THEN
25335 WRITE(LOUT,'(/1X,A,I3)')
25336 & 'MASHEL: inconsistent transformation',IDEV
25337 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25338 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25339 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25340 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25341 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25342 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25351 *$ CREATE DT_DFERMI.FOR
25354 *===dfermi=============================================================*
25356 SUBROUTINE DT_DFERMI(GPART)
25358 ************************************************************************
25359 * Find largest of three random numbers. *
25360 ************************************************************************
25362 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25368 G(I)=DT_RNDM(GPART)
25370 IF (G(3).LT.G(2)) GOTO 40
25371 IF (G(3).LT.G(1)) GOTO 30
25376 40 IF (G(2).LT.G(1)) GOTO 30
25382 ************************************************************************
25384 * 2) Handling of parton flavors and particle indices *
25386 ************************************************************************
25387 *$ CREATE IDT_IPDG2B.FOR
25390 *===ipdg2b=============================================================*
25392 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25394 ************************************************************************
25396 * conversion of quark numbering scheme *
25398 * input: PDG parton numbering *
25399 * for diquarks: NN number of the constituent quark *
25400 * (e.g. ID=2301,NN=1 -> ICONV2=1) *
25402 * output: BAMJET particle codes *
25403 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25404 * 2 d 8 a-d -2 a-d *
25405 * 3 s 9 a-s -3 a-s *
25406 * 4 c 10 a-c -4 a-c *
25408 * This is a modified version of ICONV2 written by R. Engel. *
25409 * This version dated 13.12.94 is written by S. Roesler. *
25410 ************************************************************************
25412 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25414 PARAMETER ( LINP = 10 ,
25422 IF (IDA.GE.1000) KF = 4
25423 IDA = IDA/(10**(KF-NN))
25426 * exchange up and dn quarks
25429 ELSEIF (IDA.EQ.2) THEN
25434 IF (MODE.EQ.1) THEN
25445 *$ CREATE IDT_IB2PDG.FOR
25448 *===ib2pdg=============================================================*
25450 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25452 ************************************************************************
25454 * conversion of quark numbering scheme *
25456 * input: BAMJET particle codes *
25457 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25458 * 2 d 8 a-d -2 a-d *
25459 * 3 s 9 a-s -3 a-s *
25460 * 4 c 10 a-c -4 a-c *
25462 * output: PDG parton numbering *
25464 * This version dated 13.12.94 is written by S. Roesler. *
25465 ************************************************************************
25467 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25469 PARAMETER ( LINP = 10 ,
25473 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25474 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25475 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25476 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25477 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25481 IF (MODE.EQ.1) THEN
25482 IF (ID1.GT.6) IDA = -(ID1-6)
25483 IF (ID2.GT.6) IDB = -(ID2-6)
25486 IDT_IB2PDG = IHKKQ(IDA)
25488 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25494 *$ CREATE IDT_IQUARK.FOR
25497 *===ipdgqu=============================================================*
25499 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25501 ************************************************************************
25503 * quark contents according to PDG conventions *
25504 * (random selection in case of quark mixing) *
25506 * input: IDBAMJ BAMJET particle code *
25507 * K 1..3 quark number *
25509 * output: 1 d (anti --> neg.) *
25514 * This version written by R. Engel. *
25515 ************************************************************************
25517 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25520 IQ = IDT_IBJQUA(K,IDBAMJ)
25525 * exchange of up and down
25526 IF (ABS(IQ).EQ.1) THEN
25528 ELSEIF (ABS(IQ).EQ.2) THEN
25536 *$ CREATE IDT_IBJQUA.FOR
25539 *===ibamq==============================================================*
25541 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25543 ************************************************************************
25545 * quark contents according to BAMJET conventions *
25546 * (random selection in case of quark mixing) *
25548 * input: IDBAMJ BAMJET particle code *
25549 * K 1..3 quark number *
25551 * output: 1 u 7 u bar *
25556 * This version written by R. Engel. *
25557 ************************************************************************
25559 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25562 DIMENSION ITAB(3,210)
25563 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25564 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25565 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25566 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25568 C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25569 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25571 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25573 C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25574 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25576 C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25577 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25579 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25580 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25581 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25582 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25583 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25584 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25585 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
25586 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25587 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25588 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25589 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25590 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
25591 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25592 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25593 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25594 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25595 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25596 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25597 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25598 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25599 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25600 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25601 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25602 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25603 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25604 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25605 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25606 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25607 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25608 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25609 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25610 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25611 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25612 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25613 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25614 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25615 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25616 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25617 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25618 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25619 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25620 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25621 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25622 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25623 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25624 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25625 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25626 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25627 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25628 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25629 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25630 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25631 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25632 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25633 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25634 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25635 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25636 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25637 DATA ((ITAB(I,K),I=1,3),K=181,210) /
25638 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25639 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25640 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25641 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25642 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25643 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25644 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25645 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25646 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25647 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25651 IF (ITAB(1,IDBAMJ).LE.200) THEN
25652 ID = ITAB(K,IDBAMJ)
25654 IF(IDOLD.NE.IDBAMJ) THEN
25655 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25656 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25668 *$ CREATE IDT_ICIHAD.FOR
25671 *===icihad=============================================================*
25673 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25675 ************************************************************************
25676 * Conversion of particle index PDG proposal --> BAMJET-index scheme *
25677 * This is a completely new version dated 25.10.95. *
25678 * Renamed to be not in conflict with the modified PHOJET-version *
25679 ************************************************************************
25681 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25684 * hadron index conversion (BAMJET <--> PDG)
25685 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25686 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25691 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25692 IF (MCIND.LT.0) THEN
25697 IF (KPDG.GE.10000) THEN
25699 IDT_ICIHAD = IBAM5(JSIGN,I)
25700 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25703 ELSEIF (KPDG.GE.1000) THEN
25705 IDT_ICIHAD = IBAM4(JSIGN,I)
25706 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25709 ELSEIF (KPDG.GE.100) THEN
25711 IDT_ICIHAD = IBAM3(JSIGN,I)
25712 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25715 ELSEIF (KPDG.GE.10) THEN
25717 IDT_ICIHAD = IBAM2(JSIGN,I)
25718 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25727 *$ CREATE IDT_IPDGHA.FOR
25730 *===ipdgha=============================================================*
25732 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25734 ************************************************************************
25735 * Conversion of particle index BAMJET-index scheme --> PDG proposal *
25736 * Adopted from the original by S. Roesler. This version dated 12.5.95 *
25737 * Renamed to be not in conflict with the modified PHOJET-version *
25738 ************************************************************************
25740 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25743 * hadron index conversion (BAMJET <--> PDG)
25744 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25745 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25748 IDT_IPDGHA = IAMCIN(MCIND)
25753 *$ CREATE DT_FLAHAD.FOR
25756 *===flahad=============================================================*
25758 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25760 ************************************************************************
25761 * sampling of FLAvor composition for HADrons/photons *
25762 * ID BAMJET-id of hadron *
25763 * IF1,2,3 flavor content *
25764 * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25765 * Note: - u,d numbering as in BAMJET *
25766 * - ID .le. 30 !! *
25767 * This version dated 12.03.96 is written by S. Roesler *
25768 ************************************************************************
25770 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25773 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25774 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25775 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25776 & IQTCHR(-6:6),MQUARK(3,39)
25778 DIMENSION JSEL(3,6)
25779 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25783 * photon (charge dependent flavour sampling)
25784 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25788 ELSE IF(K.EQ.5) THEN
25795 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25803 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25804 IF1 = MQUARK(JSEL(1,IX),ID)
25805 IF2 = MQUARK(JSEL(2,IX),ID)
25806 IF3 = MQUARK(JSEL(3,IX),ID)
25807 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25810 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25819 *$ CREATE IDT_MCHAD.FOR
25822 *===mchad==============================================================*
25824 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25826 ************************************************************************
25827 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25828 * Adopted from the original by S. Roesler. This version dated 6.5.95 *
25830 * Last change 28.12.2006 by S. Roesler. *
25831 ************************************************************************
25833 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25836 DIMENSION ITRANS(210)
25837 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25838 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25839 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25840 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25841 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25842 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25843 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25845 IF ( ITDTU .GT. 0 ) THEN
25846 IDT_MCHAD = ITRANS(ITDTU)
25854 ************************************************************************
25856 * 3) Energy-momentum and quantum number conservation check routines *
25858 ************************************************************************
25859 *$ CREATE DT_EMC1.FOR
25862 *===emc1===============================================================*
25864 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25866 ************************************************************************
25867 * This version dated 15.12.94 is written by S. Roesler *
25868 ************************************************************************
25870 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25872 PARAMETER ( LINP = 10 ,
25875 PARAMETER (TINY10=1.0D-10)
25877 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25881 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25882 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25884 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25885 IF (MODE.EQ.1) THEN
25886 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25887 ELSEIF (MODE.EQ.2) THEN
25888 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25890 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25891 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25892 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25893 ELSEIF (MODE.LT.0) THEN
25894 IF (MODE.EQ.-1) THEN
25895 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25896 ELSEIF (MODE.EQ.-2) THEN
25897 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25899 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25900 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25901 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25904 IF (ABS(MODE).EQ.3) THEN
25905 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25906 IF (IREJ1.NE.0) GOTO 9999
25915 *$ CREATE DT_EMC2.FOR
25918 *===emc2===============================================================*
25920 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25923 ************************************************************************
25924 * MODE = 1 energy-momentum cons. check *
25925 * = 2 flavor-cons. check *
25926 * = 3 energy-momentum & flavor cons. check *
25927 * = 4 energy-momentum & charge cons. check *
25928 * = 5 energy-momentum & flavor & charge cons. check *
25929 * This version dated 16.01.95 is written by S. Roesler *
25930 ************************************************************************
25932 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25934 PARAMETER ( LINP = 10 ,
25937 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25940 PARAMETER (NMXHKK=200000)
25941 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25942 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25943 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25944 * extended event history
25945 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25946 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25954 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25955 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25956 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25957 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25958 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25960 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25961 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25962 & (ISTHKK(I).EQ.IP5)) THEN
25963 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25965 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25967 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25968 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25969 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25970 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25972 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25973 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25974 & (ISTHKK(I).EQ.IN5)) THEN
25975 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25977 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25979 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25980 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25981 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25982 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25985 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25986 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25987 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25988 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25989 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25990 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25999 *$ CREATE DT_EVTEMC.FOR
26002 *===evtemc=============================================================*
26004 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
26006 ************************************************************************
26007 * This version dated 13.12.94 is written by S. Roesler *
26008 ************************************************************************
26010 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26012 PARAMETER ( LINP = 10 ,
26015 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
26019 PARAMETER (NMXHKK=200000)
26020 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26021 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26022 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26023 * flags for input different options
26024 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26025 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26026 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26032 IF (MODE.EQ.4) THEN
26035 ELSEIF (MODE.EQ.5) THEN
26038 ELSEIF (MODE.EQ.-1) THEN
26043 IF (ABS(MODE).EQ.3) THEN
26048 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26049 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26050 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26051 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26052 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26053 & ' event ',NEVHKK,
26054 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26068 IF (MODE.EQ.1) THEN
26087 *$ CREATE DT_EVTFLC.FOR
26090 *===evtflc=============================================================*
26092 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26094 ************************************************************************
26095 * Flavor conservation check. *
26096 * ID identity of particle *
26097 * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
26098 * = 2 ID for particle/resonance in BAMJET numbering scheme *
26099 * = 3 ID for particle/resonance in PDG numbering scheme *
26100 * MODE = 1 initialization and add ID *
26101 * =-1 initialization and subtract ID *
26103 * =-2 subtract ID *
26104 * = 3 check flavor cons. *
26105 * IPOS flag to give position of call of EVTFLC to output *
26106 * unit in case of violation *
26107 * This version dated 10.01.95 is written by S. Roesler *
26108 ************************************************************************
26110 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26112 PARAMETER ( LINP = 10 ,
26115 PARAMETER (TINY10=1.0D-10)
26119 IF (MODE.EQ.3) THEN
26121 WRITE(LOUT,'(1X,A,I3,A,I3)')
26122 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26131 IF (MODE.EQ.1) IFL = 0
26132 IF (ID.EQ.0) RETURN
26137 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26138 IF (IDD.GE.1000) NQ = 3
26140 IFBAM = IDT_IPDG2B(ID,I,2)
26141 IF (ABS(IFBAM).EQ.1) THEN
26142 IFBAM = SIGN(2,IFBAM)
26143 ELSEIF (ABS(IFBAM).EQ.2) THEN
26144 IFBAM = SIGN(1,IFBAM)
26146 IF (MODE.GT.0) THEN
26156 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26157 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26159 IF (MODE.GT.0) THEN
26160 IFL = IFL+IDT_IQUARK(I,IDD)
26162 IFL = IFL-IDT_IQUARK(I,IDD)
26173 *$ CREATE DT_EVTCHG.FOR
26176 *===evtchg=============================================================*
26178 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26180 ************************************************************************
26181 * Charge conservation check. *
26182 * ID identity of particle (PDG-numbering scheme) *
26183 * MODE = 1 initialization *
26184 * =-2 subtract ID-charge *
26185 * = 2 add ID-charge *
26186 * = 3 check charge cons. *
26187 * IPOS flag to give position of call of EVTCHG to output *
26188 * unit in case of violation *
26189 * This version dated 10.01.95 is written by S. Roesler *
26190 * Last change: s.r. 21.01.01 *
26191 ************************************************************************
26193 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26195 PARAMETER ( LINP = 10 ,
26200 PARAMETER (NMXHKK=200000)
26201 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26202 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26203 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26204 * particle properties (BAMJET index convention)
26206 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26207 & IICH(210),IIBAR(210),K1(210),K2(210)
26211 IF (MODE.EQ.1) THEN
26217 IF (MODE.EQ.3) THEN
26218 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26219 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26220 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26221 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26231 IF (ID.EQ.0) RETURN
26233 IDD = IDT_ICIHAD(ID)
26234 * modification 21.1.01: use intrinsic phojet-functions to determine charge
26235 * and baryon number
26236 C IF (IDD.GT.0) THEN
26237 C IF (MODE.EQ.2) THEN
26238 C ICH = ICH+IICH(IDD)
26239 C IBAR = IBAR+IIBAR(IDD)
26240 C ELSEIF (MODE.EQ.-2) THEN
26241 C ICH = ICH-IICH(IDD)
26242 C IBAR = IBAR-IIBAR(IDD)
26245 C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26246 C CALL DT_EVTOUT(4)
26249 IF (MODE.EQ.2) THEN
26250 ICH = ICH+IPHO_CHR3(ID,1)/3
26251 IBAR = IBAR+IPHO_BAR3(ID,1)/3
26252 ELSEIF (MODE.EQ.-2) THEN
26253 ICH = ICH-IPHO_CHR3(ID,1)/3
26254 IBAR = IBAR-IPHO_BAR3(ID,1)/3
26264 ************************************************************************
26266 * 4) Transformations *
26268 ************************************************************************
26269 *$ CREATE DT_LTINI.FOR
26272 *===ltini==============================================================*
26274 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26276 ************************************************************************
26277 * Initializations of Lorentz-transformations, calculation of Lorentz- *
26279 * This version dated 13.11.95 is written by S. Roesler. *
26280 ************************************************************************
26282 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26284 PARAMETER ( LINP = 10 ,
26287 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26288 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26290 * Lorentz-parameters of the current interaction
26291 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26292 & UMO,PPCM,EPROJ,PPROJ
26293 * properties of photon/lepton projectiles
26294 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26295 * particle properties (BAMJET index convention)
26297 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26298 & IICH(210),IIBAR(210),K1(210),K2(210)
26299 * nucleon-nucleon event-generator
26302 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26306 IF (MCGENE.NE.3) THEN
26307 * lepton-projectiles and PHOJET: initialize real photon instead
26308 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26309 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26310 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26319 AMP = AAM(IDP)-SQRT(ABS(Q2))
26321 AMP2 = SIGN(AMP**2,AMP)
26323 IF (ECM0.GT.ZERO) THEN
26324 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26325 IF (AMP2.GT.ZERO) THEN
26326 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26328 PPN = SQRT(EPN**2-AMP2)
26331 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26332 IF (IDP.EQ.7) EPN = ABS(EPN)
26333 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26334 IF (AMP2.GT.ZERO) THEN
26335 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26337 PPN = SQRT(EPN**2-AMP2)
26339 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26340 IF (AMP2.GT.ZERO) THEN
26341 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26343 EPN = SQRT(PPN**2+AMP2)
26346 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26351 IF (AMP2.GT.ZERO) THEN
26352 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26353 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26358 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26364 IF (ECM0.GT.ZERO) THEN
26367 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26368 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26369 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26370 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26373 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26374 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26375 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26376 IF (MODE.EQ.1) THEN
26379 PNUCL(3) = -PGAMM(3)
26380 PNUCL(4) = SQRT(S)-PGAMM(4)
26383 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26384 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26387 * neglect lepton masses
26388 C AMLPT2 = AAM(IDPR)**2
26391 IF (ECM0.GT.ZERO) THEN
26394 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26395 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26396 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26397 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26400 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26401 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26402 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26405 PNUCL(3) = -PLEPT0(3)
26406 PNUCL(4) = SQRT(S)-PLEPT0(4)
26408 * Lorentz-parameter for transformation Lab. - projectile rest system
26409 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26418 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26423 GACMS(1) = (ETARG+AMP)/UMO
26424 BGCMS(1) = PTARG/UMO
26426 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26427 GACMS(2) = (EPROJ+AMT)/UMO
26428 BGCMS(2) = PPROJ/UMO
26429 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26438 *$ CREATE DT_LTRANS.FOR
26441 *===ltrans=============================================================*
26443 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26445 ************************************************************************
26446 * Lorentz-transformations. *
26447 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
26448 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26449 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26450 * This version dated 01.11.95 is written by S. Roesler. *
26451 ************************************************************************
26453 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26455 PARAMETER ( LINP = 10 ,
26458 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26460 PARAMETER (SQTINF=1.0D+15)
26462 * particle properties (BAMJET index convention)
26464 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26465 & IICH(210),IIBAR(210),K1(210),K2(210)
26469 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26471 * check particle mass for consistency (numerical rounding errors)
26472 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26473 AMO2 = (PEO-PO)*(PEO+PO)
26474 AMORQ2 = AAM(ID)**2
26475 AMDIF2 = ABS(AMO2-AMORQ2)
26476 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26477 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26483 C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26489 *$ CREATE DT_LTNUC.FOR
26492 *===ltnuc==============================================================*
26494 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26496 ************************************************************************
26497 * Lorentz-transformations. *
26498 * PIN longitudnal momentum (input) *
26499 * EIN energy (input) *
26500 * POUT transformed long. momentum (output) *
26501 * EOUT transformed energy (output) *
26502 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
26503 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26504 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26505 * This version dated 01.11.95 is written by S. Roesler. *
26506 ************************************************************************
26508 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26510 PARAMETER ( LINP = 10 ,
26513 PARAMETER (ZERO=0.0D0)
26515 * Lorentz-parameters of the current interaction
26516 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26517 & UMO,PPCM,EPROJ,PPROJ
26523 IF (ABS(MODE).EQ.1) THEN
26524 BG = -SIGN(BGLAB,DBLE(MODE))
26525 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26526 & DUM1,DUM2,DUM3,POUT,EOUT)
26527 ELSEIF (ABS(MODE).EQ.2) THEN
26528 BG = SIGN(BGCMS(1),DBLE(MODE))
26529 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26530 & DUM1,DUM2,DUM3,POUT,EOUT)
26531 ELSEIF (ABS(MODE).EQ.3) THEN
26532 BG = -SIGN(BGCMS(2),DBLE(MODE))
26533 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26534 & DUM1,DUM2,DUM3,POUT,EOUT)
26536 WRITE(LOUT,1000) MODE
26537 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26545 *$ CREATE DT_DALTRA.FOR
26548 *===daltra=============================================================*
26550 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26552 ************************************************************************
26553 * Arbitrary Lorentz-transformation. *
26554 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26555 ************************************************************************
26557 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26559 PARAMETER (ONE=1.0D0)
26561 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26562 PE = EP/(GA+ONE)+EC
26566 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26572 *$ CREATE DT_DTRAFO.FOR
26575 *====dtrafo============================================================*
26577 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26578 & PL,CXL,CYL,CZL,EL)
26580 C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26582 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26585 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26586 SID = SQRT(1.D0-COD*COD)
26590 PLZ = GAM*PCMZ+BGAM*ECM
26591 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26592 EL = GAM*ECM+BGAM*PCMZ
26593 C ROTATION INTO THE ORIGINAL DIRECTION
26595 SIZ = SQRT(1.D0-COZ**2)
26596 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26601 *$ CREATE DT_STTRAN.FOR
26604 *====sttran============================================================*
26606 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26608 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26610 DATA ANGLSQ/1.D-30/
26611 ************************************************************************
26612 * VERSION BY J. RANFT *
26615 * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26617 * INPUT VARIABLES: *
26618 * XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26619 * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26620 * ANGLE OF "SCATTERING" *
26621 * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26622 * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26623 * OF "SCATTERING" *
26625 * OUTPUT VARIABLES: *
26626 * X,Y,Z = NEW DIRECTION COSINES *
26628 * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26629 ************************************************************************
26632 * Changed by A. Ferrari
26634 * IF (ABS(XO)-0.0001D0) 1,1,2
26635 * 1 IF (ABS(YO)-0.0001D0) 3,3,2
26638 IF ( A .LT. ANGLSQ ) THEN
26647 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26648 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26655 *$ CREATE DT_MYTRAN.FOR
26658 *===mytran=============================================================*
26660 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26662 ************************************************************************
26663 * This subroutine rotates the coordinate frame *
26664 * a) theta around y *
26665 * b) phi around z if IMODE = 1 *
26667 * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26668 * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26669 * z' 0 0 1 -sin(th) 0 cos(th) z *
26671 * and vice versa if IMODE = 0. *
26672 * This version dated 5.4.94 is based on the original version DTRAN *
26673 * by J. Ranft and is written by S. Roesler. *
26674 ************************************************************************
26676 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26678 PARAMETER ( LINP = 10 ,
26682 IF (IMODE.EQ.1) THEN
26683 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26684 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26685 Z=-SDE *XO +CDE *ZO
26687 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26689 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26694 *$ CREATE DT_LT2LAO.FOR
26697 *===lt2lab=============================================================*
26699 SUBROUTINE DT_LT2LAO
26701 ************************************************************************
26702 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26703 * for final state particles/fragments defined in nucleon-nucleon-cms *
26704 * and transforms them back to the lab. *
26705 * This version dated 16.11.95 is written by S. Roesler *
26706 ************************************************************************
26708 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26710 PARAMETER ( LINP = 10 ,
26715 PARAMETER (NMXHKK=200000)
26716 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26717 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26718 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26719 * extended event history
26720 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26721 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26726 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26727 DO 1 I=NPOINT(4),NEND
26729 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26730 & (ISTHKK(I).EQ.1001)) THEN
26731 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26733 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26734 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26735 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26736 ISTHKK(I) = 3*ISTHKK(I)
26739 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26740 ISTHKK(I) = SIGN(3,ISTHKK(I))
26749 *$ CREATE DT_LT2LAB.FOR
26752 *===lt2lab=============================================================*
26754 SUBROUTINE DT_LT2LAB
26756 ************************************************************************
26757 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26758 * for final state particles/fragments defined in nucleon-nucleon-cms *
26759 * and transforms them to the lab. *
26760 * This version dated 07.01.96 is written by S. Roesler *
26761 ************************************************************************
26763 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26765 PARAMETER ( LINP = 10 ,
26770 PARAMETER (NMXHKK=200000)
26771 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26772 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26773 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26774 * extended event history
26775 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26776 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26779 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26780 DO 1 I=NPOINT(4),NHKK
26781 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26782 & (ISTHKK(I).EQ.1001)) THEN
26783 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26792 ************************************************************************
26794 * 5) Sampling from distributions *
26796 ************************************************************************
26797 *$ CREATE IDT_NPOISS.FOR
26800 *===npoiss=============================================================*
26802 INTEGER FUNCTION IDT_NPOISS(AVN)
26804 ************************************************************************
26805 * Sample according to Poisson distribution with Poisson parameter AVN. *
26806 * The original version written by J. Ranft. *
26807 * This version dated 11.1.95 is written by S. Roesler. *
26808 ************************************************************************
26810 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26812 PARAMETER ( LINP = 10 ,
26822 IF (A.GE.EXPAVN) THEN
26831 *$ CREATE DT_SAMPXB.FOR
26834 *===sampxb=============================================================*
26836 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26838 ************************************************************************
26839 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26840 * Processed by S. Roesler, 6.5.95 *
26841 ************************************************************************
26843 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26845 PARAMETER (TWO=2.0D0)
26847 A1 = LOG(X1+SQRT(X1**2+B**2))
26848 A2 = LOG(X2+SQRT(X2**2+B**2))
26850 A = AN*DT_RNDM(A1)+A1
26852 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26857 *$ CREATE DT_SAMPEX.FOR
26860 *===sampex=============================================================*
26862 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26864 ************************************************************************
26865 * Sampling from f(x)=1./x between x1 and x2. *
26866 * Processed by S. Roesler, 6.5.95 *
26867 ************************************************************************
26869 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26871 PARAMETER (ONE=1.0D0)
26876 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26881 *$ CREATE DT_SAMSQX.FOR
26884 *===samsqx=============================================================*
26886 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26888 ************************************************************************
26889 * Sampling from f(x)=1./x^0.5 between x1 and x2. *
26890 * Processed by S. Roesler, 6.5.95 *
26891 ************************************************************************
26893 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26895 PARAMETER (ONE=1.0D0)
26898 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26903 *$ CREATE DT_SAMPLW.FOR
26906 *===samplw=============================================================*
26908 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26910 ************************************************************************
26911 * Sampling from f(x)=1/x^b between x_min and x_max. *
26912 * S. Roesler, 18.4.98 *
26913 ************************************************************************
26915 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26917 PARAMETER (ONE=1.0D0)
26921 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26924 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26930 *$ CREATE DT_BETREJ.FOR
26933 *===betrej=============================================================*
26935 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26937 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26940 PARAMETER ( LINP = 10 ,
26943 PARAMETER (ONE=1.0D0)
26945 IF (XMIN.GE.XMAX)THEN
26946 WRITE (LOUT,500) XMIN,XMAX
26947 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26952 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26953 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26954 YY = BETMAX*DT_RNDM(XX)
26955 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26956 IF (YY.GT.BETXX) GOTO 10
26962 *$ CREATE DT_DGAMRN.FOR
26965 *===dgamrn=============================================================*
26967 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26969 ************************************************************************
26970 * Sampling from Gamma-distribution. *
26971 * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26972 * Processed by S. Roesler, 6.5.95 *
26973 ************************************************************************
26975 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26977 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26982 IF (F.EQ.ZERO) GOTO 20
26985 IF (NCOU.GE.11) GOTO 20
26986 IF (R.LT.F/(F+2.71828D0)) GOTO 30
26987 YYY = LOG(DT_RNDM(R)+TINY9)/F
26988 IF (ABS(YYY).GT.50.0D0) GOTO 20
26990 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26994 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26995 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26996 40 IF (N.EQ.0) GOTO 70
26999 60 Z = Z*DT_RNDM(Z)
27001 70 DT_DGAMRN = Y/ALAM
27006 *$ CREATE DT_DBETAR.FOR
27009 *===dbetar=============================================================*
27011 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
27013 ************************************************************************
27014 * Sampling from Beta -distribution between 0.0 and 1.0 *
27015 * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
27016 * Processed by S. Roesler, 6.5.95 *
27017 ************************************************************************
27019 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27022 Y = DT_DGAMRN(1.0D0,GAM)
27023 Z = DT_DGAMRN(1.0D0,ETA)
27024 DT_DBETAR = Y/(Y+Z)
27029 *$ CREATE DT_RANNOR.FOR
27032 *===rannor=============================================================*
27034 SUBROUTINE DT_RANNOR(X,Y)
27036 ************************************************************************
27037 * Sampling from Gaussian distribution. *
27038 * Processed by S. Roesler, 6.5.95 *
27039 ************************************************************************
27041 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27043 PARAMETER (TINY10=1.0D-10)
27045 CALL DT_DSFECF(SFE,CFE)
27046 V = MAX(TINY10,DT_RNDM(X))
27047 A = SQRT(-2.D0*LOG(V))
27054 *$ CREATE DT_DPOLI.FOR
27057 *===dpoli==============================================================*
27059 SUBROUTINE DT_DPOLI(CS,SI)
27061 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27066 IF (U.LT.0.5D0) CS=-CS
27067 SI = SQRT(1.0D0-CS*CS+1.0D-10)
27072 *$ CREATE DT_DSFECF.FOR
27075 *===dsfecf=============================================================*
27077 SUBROUTINE DT_DSFECF(SFE,CFE)
27079 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27081 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27089 IF (XY.GT.ONE) GOTO 1
27092 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27096 *$ CREATE DT_RACO.FOR
27099 *===raco===============================================================*
27101 SUBROUTINE DT_RACO(WX,WY,WZ)
27103 ************************************************************************
27104 * Direction cosines of random uniform (isotropic) direction in three *
27105 * dimensional space *
27106 * Processed by S. Roesler, 20.11.95 *
27107 ************************************************************************
27109 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27111 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27114 X = TWO*DT_RNDM(WX)-ONE
27118 IF (X2+Y2.GT.ONE) GOTO 10
27120 CFE = (X2-Y2)/(X2+Y2)
27121 SFE = TWO*X*Y/(X2+Y2)
27122 * z = 1/2 [ 1 + cos (theta) ]
27125 WZ = SQRT(Z*(ONE-Z))
27133 ************************************************************************
27135 * 6) Special functions, algorithms and service routines *
27137 ************************************************************************
27138 *$ CREATE DT_YLAMB.FOR
27141 *===ylamb==============================================================*
27143 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27145 ************************************************************************
27147 * auxiliary function for three particle decay mode *
27148 * (standard LAMBDA**(1/2) function) *
27150 * Adopted from an original version written by R. Engel. *
27151 * This version dated 12.12.94 is written by S. Roesler. *
27152 ************************************************************************
27154 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27158 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27159 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27160 DT_YLAMB = SQRT(XLAM)
27165 *$ CREATE DT_SORT.FOR
27168 *===sort1==============================================================*
27170 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27172 ************************************************************************
27173 * This subroutine sorts entries in A in increasing/decreasing order *
27175 * MODE = 1 increasing in A(3,i=1..N) *
27176 * = 2 decreasing in A(3,i=1..N) *
27177 * This version dated 21.04.95 is revised by S. Roesler *
27178 ************************************************************************
27180 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27192 IF (MODE.EQ.1) THEN
27193 IF (A(3,I).LE.A(3,J)) GOTO 20
27195 IF (A(3,I).GE.A(3,J)) GOTO 20
27208 IF (L.EQ.1) GOTO 10
27213 *$ CREATE DT_SORT1.FOR
27216 *===sort1==============================================================*
27218 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27220 ************************************************************************
27221 * This subroutine sorts entries in A in increasing/decreasing order *
27223 * MODE = 1 increasing in A(i=1..N) *
27224 * = 2 decreasing in A(i=1..N) *
27225 * This version dated 21.04.95 is revised by S. Roesler *
27226 ************************************************************************
27228 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27231 DIMENSION A(N),IDX(N)
27240 IF (MODE.EQ.1) THEN
27241 IF (A(I).LE.A(J)) GOTO 20
27243 IF (A(I).GE.A(J)) GOTO 20
27253 IF (L.EQ.1) GOTO 10
27258 *$ CREATE DT_XTIME.FOR
27261 *===xtime==============================================================*
27263 SUBROUTINE DT_XTIME
27265 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27267 PARAMETER ( LINP = 10 ,
27271 CHARACTER DAT*9,TIM*11
27275 C CALL GETDAT(IYEAR,IMONTH,IDAY)
27276 C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27280 C WRITE(LOUT,1000) DAT,TIM
27281 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27286 ************************************************************************
27288 * 7) Random number generator package *
27290 * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
27291 * SERVICE ROUTINES. *
27292 * THE ALGORITHM IS FROM *
27293 * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27294 * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27295 * IMPLEMENTATION BY K. HAHN DEC. 88, *
27296 * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27297 * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27298 * THE PERIOD IS ABOUT 2**144, *
27299 * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27300 * THE PACKAGE CONTAINS *
27301 * FUNCTION DT_RNDM(I) : GENERATOR *
27302 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27303 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27304 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27305 * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27307 * FUNCTION DT_RNDM(I) *
27308 * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27309 * I - DUMMY VARIABLE, NOT USED *
27310 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27311 * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27312 * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27313 * NA? MUST BE IN 1..178 AND NOT ALL 1 *
27314 * 12,34,56 ARE THE STANDARD VALUES *
27315 * NB1 MUST BE IN 1..168 *
27316 * 78 IS THE STANDARD VALUE *
27317 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27318 * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27319 * AS AFTER THE LAST DT_RNDMOU CALL ) *
27320 * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27321 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27322 * TAKES SEED FROM GENERATOR *
27323 * U(97),C,CD,CM,I,J - SEED VALUES *
27324 * SUBROUTINE DT_RNDMTE(IO) *
27325 * TEST OF THE GENERATOR *
27326 * IO - DEFINES OUTPUT *
27327 * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27328 * = 1 OUTPUT INDEPENDEND ON AN ERROR *
27329 * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27331 * AS BEFORE CALL OF DT_RNDMTE *
27332 ************************************************************************
27333 *$ CREATE DT_RNDM.FOR
27336 c$$$*===rndm===============================================================*
27338 c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27340 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27343 c$$$* random number generator
27344 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27346 c$$$* counter of calls to random number generator
27347 c$$$* uncomment if needed
27348 c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27349 c$$$C LOGICAL LFIRST
27350 c$$$C DATA LFIRST /.TRUE./
27352 c$$$* counter of calls to random number generator
27353 c$$$* uncomment if needed
27354 c$$$C IF (LFIRST) THEN
27357 c$$$C LFIRST = .FALSE.
27360 c$$$ DT_RNDM = U(I)-U(J)
27361 c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27362 c$$$ U(I) = DT_RNDM
27364 c$$$ IF ( I.EQ.0 ) I = 97
27366 c$$$ IF ( J.EQ.0 ) J = 97
27368 c$$$ IF ( C.LT.0.0D0 ) C = C+CM
27369 c$$$ DT_RNDM = DT_RNDM-C
27370 c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27372 c$$$ IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27374 c$$$* counter of calls to random number generator
27375 c$$$* uncomment if needed
27376 c$$$C IRNCT0 = IRNCT0+1
27381 c$$$*$ CREATE DT_RNDMST.FOR
27382 c$$$*COPY DT_RNDMST
27384 c$$$*===rndmst=============================================================*
27386 c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27388 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27391 c$$$* random number generator
27392 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27400 c$$$ DO 20 II2 = 1,97
27403 c$$$ DO 10 II1 = 1,24
27404 c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27408 c$$$ MB1 = MOD(53*MB1+1,169)
27409 c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27410 c$$$ 10 T = 0.5D0*T
27412 c$$$ C = 362436.0D0/16777216.0D0
27413 c$$$ CD = 7654321.0D0/16777216.0D0
27414 c$$$ CM = 16777213.0D0/16777216.0D0
27418 c$$$*$ CREATE DT_RNDMIN.FOR
27419 c$$$*COPY DT_RNDMIN
27421 c$$$*===rndmin=============================================================*
27423 c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27425 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27428 c$$$* random number generator
27429 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27431 c$$$ DIMENSION UIN(97)
27433 c$$$ DO 10 KKK = 1,97
27434 c$$$ 10 U(KKK) = UIN(KKK)
27444 c$$$*$ CREATE DT_RNDMOU.FOR
27445 c$$$*COPY DT_RNDMOU
27447 c$$$*===rndmou=============================================================*
27449 c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27451 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27454 c$$$* random number generator
27455 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27457 c$$$ DIMENSION UOUT(97)
27459 c$$$ DO 10 KKK = 1,97
27460 c$$$ 10 UOUT(KKK) = U(KKK)
27470 c$$$*$ CREATE DT_RNDMTE.FOR
27471 c$$$*COPY DT_RNDMTE
27473 c$$$*===rndmte=============================================================*
27475 c$$$ SUBROUTINE DT_RNDMTE(IO)
27477 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27480 c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27481 c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27482 c$$$ +8354498.D0, 10633180.D0/
27484 c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27485 c$$$ CALL DT_RNDMST(12,34,56,78)
27486 c$$$ DO 10 II1 = 1,20000
27487 c$$$ 10 XX = DT_RNDM(XX)
27489 c$$$ DO 20 II2 = 1,6
27490 c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27491 c$$$ D(II2) = X(II2)-U(II2)
27492 c$$$ 20 SD = SD+D(II2)
27493 c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27495 c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27496 c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27497 c$$$C WRITE(6,1000)
27498 c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27503 c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27504 c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27505 c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27506 c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27509 *$ CREATE PHO_RNDM.FOR
27512 *===pho_rndm===========================================================*
27514 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27516 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27519 PHO_RNDM = DT_RNDM(DUMMY)
27527 *===pyr================================================================*
27529 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27531 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27534 DUMMY = DBLE(IDUMMY)
27535 PYR = DT_RNDM(DUMMY)
27540 *$ CREATE DT_TITLE.FOR
27543 *===title==============================================================*
27545 SUBROUTINE DT_TITLE
27547 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27549 PARAMETER ( LINP = 10 ,
27554 CHARACTER*11 CCHANG
27555 DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27558 WRITE(LOUT,1000) CVERSI,CCHANG
27559 1000 FORMAT(1X,'+-------------------------------------------------',
27560 & '----------------------+',/,
27561 & 1X,'|',71X,'|',/,
27562 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27563 & 1X,'|',71X,'|',/,
27564 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27565 & 1X,'|',71X,'|',/,
27566 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27567 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27568 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27569 & 1X,'|',71X,'|',/,
27570 & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27572 & 1X,'|',71X,'|',/,
27573 & 1X,'+-------------------------------------------------',
27574 & '----------------------+',/,
27575 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27576 & 'Stefan.Roesler@cern.ch |',/,
27577 & 1X,'+-------------------------------------------------',
27578 & '----------------------+',/)
27583 *$ CREATE DT_EVTINI.FOR
27586 *===evtini=============================================================*
27588 SUBROUTINE DT_EVTINI
27590 ************************************************************************
27591 * Initialization of DTEVT1. *
27592 * This version dated 15.01.94 is written by S. Roesler *
27593 ************************************************************************
27595 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27597 PARAMETER ( LINP = 10 ,
27602 PARAMETER (NMXHKK=200000)
27603 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27604 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27605 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27606 * extended event history
27607 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27608 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27611 COMMON /DTEVNO/ NEVENT,ICASCA
27612 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27613 * emulsion treatment
27614 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27617 * initialization of DTEVT1/DTEVT2
27619 IF (NEVENT.EQ.1) NEND = NMXHKK
27647 C* initialization of DTLTRA
27648 C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27653 *$ CREATE DT_STATIS.FOR
27656 *===statis=============================================================*
27658 SUBROUTINE DT_STATIS(MODE)
27660 ************************************************************************
27661 * Initialization and output of run-statistics. *
27662 * MODE = 1 initialization *
27664 * This version dated 23.01.94 is written by S. Roesler *
27665 ************************************************************************
27667 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27669 PARAMETER ( LINP = 10 ,
27672 PARAMETER (TINY3=1.0D-3)
27675 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27676 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27678 * rejection counter
27679 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27680 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27681 & IREXCI(3),IRDIFF(2),IRINC
27682 * central particle production, impact parameter biasing
27683 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27684 * various options for treatment of partons (DTUNUC 1.x)
27685 * (chain recombination, Cronin,..)
27686 LOGICAL LCO2CR,LINTPT
27687 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27689 * nucleon-nucleon event-generator
27692 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27693 * flags for particle decays
27694 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27695 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27696 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27697 * diquark-breaking mechanism
27698 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27700 DIMENSION PP(4),PT(4)
27707 * initialize statistics counter
27720 * initialize rejection counter
27751 * statistics counter
27753 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27754 & 28X,'---------------------')
27755 IF (ICREQU.GT.0) THEN
27756 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27757 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27758 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27759 & 'event',11X,F9.1)
27761 IF (ICDIFF(1).NE.0) THEN
27762 WRITE(LOUT,1009) ICDIFF
27763 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27764 & 'low mass high mass',/,24X,'single diffraction',
27765 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27767 IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27768 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27769 & DBLE(ICSAMP)/DBLE(ICCPRO)
27770 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27771 & ' of sampled Glauber-events per event',9X,F9.1,/,
27772 & 2X,'fraction of production cross section',21X,F10.6)
27774 IF (ICSAMP.GT.0) THEN
27775 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27776 & DBLE(ICDTA)/DBLE(ICSAMP)
27777 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27778 & ' nucleons after x-sampling',2(4X,F6.2))
27781 IF (MCGENE.EQ.1) THEN
27782 IF (ICSAMP.GT.0) THEN
27783 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27784 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27785 & ' event',3X,F9.1)
27786 IF (ISICHA.EQ.1) THEN
27787 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27788 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27789 & 'of single chains per event',13X,F9.1)
27792 IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27794 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27795 & 23X,'mean number of chains mean number of chains',/,
27796 & 23X,'sampled hadronized having mass of a reso.')
27797 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27798 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27799 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27800 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27801 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27802 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27803 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27804 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27805 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27806 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27807 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27808 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27809 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27811 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27812 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27813 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27814 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27815 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27816 & DBLE(IRHHA)/DBLE(ICREQU),
27817 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27818 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27819 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27820 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27821 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27822 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27823 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27824 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27825 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27826 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27827 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27828 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27829 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27830 & F7.2,/,1X,'Total no. of rej.',
27831 & ' in chain-systems treatment (GETCSY)',/,43X,
27832 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27833 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27834 & 1X,'Total no. of rej. in DPM-treatment of one event',
27835 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27836 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27837 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27838 & 'IREXCI(3) = ',I5,/)
27840 ELSEIF (MCGENE.EQ.2) THEN
27841 WRITE(LOUT,1010) ELOJET
27842 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27845 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27846 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27847 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27848 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27849 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27850 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27851 & ((ICEVTG(I,J),I=1,8),J=3,7),
27852 & ((ICEVTG(I,J),I=1,8),J=19,21),
27853 & (ICEVTG(I,8),I=1,8),
27854 & ((ICEVTG(I,J),I=1,8),J=22,24),
27855 & (ICEVTG(I,9),I=1,8),
27856 & ((ICEVTG(I,J),I=1,8),J=25,28),
27857 & ((ICEVTG(I,J),I=1,8),J=10,18)
27858 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27859 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27860 & ' no-dif.',8I8,/,
27861 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27862 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27863 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27864 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27865 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27867 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27868 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27869 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27871 1013 FORMAT(/,1X,'2. chain system statistics -',
27872 & ' mean numbers per evt:',/,30X,'---------------------',
27873 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27874 IF (ICSAMP.GT.0) THEN
27876 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27877 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27878 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27879 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27880 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27881 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27882 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27883 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27884 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27885 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27886 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27887 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27888 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
27891 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27892 IF (ICSAMP.GT.0) THEN
27894 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27895 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27896 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27897 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27898 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27899 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27900 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27901 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27902 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27903 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27904 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27905 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27906 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
27912 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27913 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27914 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27915 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27916 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27917 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27918 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27919 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27920 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27921 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27922 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27923 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27924 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27925 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27926 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27927 & DBRKA(3,1),DBRKA(3,2),
27928 & DBRKA(3,3),DBRKA(3,4)
27929 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27930 & DBRKR(3,1),DBRKR(3,2),
27931 & DBRKR(3,3),DBRKR(3,4)
27932 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27933 & DBRKA(3,5),DBRKA(3,6),
27934 & DBRKA(3,7),DBRKA(3,8)
27935 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27936 & DBRKR(3,5),DBRKR(3,6),
27937 & DBRKR(3,7),DBRKR(3,8)
27941 IF (MCGENE.EQ.2) THEN
27942 C CALL PHO_PHIST(-2,SIGMAX)
27943 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27951 *$ CREATE DT_EVTOUT.FOR
27954 *===evtout=============================================================*
27956 SUBROUTINE DT_EVTOUT(MODE)
27958 ************************************************************************
27959 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27960 * 3 plot entries of extended DTEVT1 (DTEVT2) *
27961 * 4 plot entries of DTEVT1 and DTEVT2 *
27962 * This version dated 11.12.94 is written by S. Roesler *
27963 ************************************************************************
27965 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27967 PARAMETER ( LINP = 10 ,
27971 PARAMETER (NMXHKK=200000)
27972 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27973 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27974 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27976 DIMENSION IRANGE(NMXHKK)
27978 IF (MODE.EQ.2) RETURN
27980 CALL DT_EVTPLO(IRANGE,MODE)
27985 *$ CREATE DT_EVTPLO.FOR
27988 *===evtplo=============================================================*
27990 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27992 ************************************************************************
27993 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27994 * 2 plot entries of DTEVT1 given by IRANGE *
27995 * 3 plot entries of extended DTEVT1 (DTEVT2) *
27996 * 4 plot entries of DTEVT1 and DTEVT2 *
27997 * 5 plot rejection counter *
27998 * This version dated 11.12.94 is written by S. Roesler *
27999 ************************************************************************
28001 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28003 PARAMETER ( LINP = 10 ,
28010 PARAMETER (NMXHKK=200000)
28011 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28012 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28013 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28014 * extended event history
28015 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28016 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28018 * rejection counter
28019 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
28020 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
28021 & IREXCI(3),IRDIFF(2),IRINC
28023 DIMENSION IRANGE(NMXHKK)
28025 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
28027 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
28028 & 15X,' --------------------------',/,/,
28029 & ' ST ID M1 M2 D1 D2 PX PY',
28032 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28033 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28034 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28036 C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28037 C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28038 C & PHKK(3,I),PHKK(4,I)
28039 C WRITE(LOUT,'(4E15.4)')
28040 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28041 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28042 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
28046 C WRITE(LOUT,1006) I,ISTHKK(I),
28047 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28048 C & WHKK(2,I),WHKK(3,I)
28049 C1006 FORMAT(1X,I4,I6,6E10.3)
28053 IF (MODE.EQ.2) THEN
28058 IF (IRANGE(NC).EQ.-100) GOTO 9999
28060 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28061 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28062 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28067 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28069 1002 FORMAT(/,1X,'EVTPLO:',14X,
28070 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28071 & 15X,' -----------------------------------',/,/,
28072 & ' ST ID M1 M2 D1 D2 IDR IDXR',
28073 & ' NOBAM IDCH M',/)
28075 C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28078 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28079 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28080 CALL PYNAME(KF,CHAU)
28081 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28082 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28083 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28085 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28090 IF (MODE.EQ.5) THEN
28092 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
28093 & 15X,' --------------------------',/)
28094 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28096 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
28097 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
28098 & 1X,'IREMC = ',10I5,/,
28099 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
28105 *$ CREATE DT_EVTPUT.FOR
28108 *===evtput=============================================================*
28110 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28112 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28114 PARAMETER ( LINP = 10 ,
28117 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28118 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28121 PARAMETER (NMXHKK=200000)
28122 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28123 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28124 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28125 * extended event history
28126 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28127 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28129 * Lorentz-parameters of the current interaction
28130 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28131 & UMO,PPCM,EPROJ,PPROJ
28132 * particle properties (BAMJET index convention)
28134 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28135 & IICH(210),IIBAR(210),K1(210),K2(210)
28137 C IF (MODE.GT.100) THEN
28138 C WRITE(LOUT,'(1X,A,I5,A,I5)')
28139 C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28140 C NHKK = NHKK-MODE+100
28147 IF (NHKK.GT.NMXHKK) THEN
28148 WRITE(LOUT,1000) NHKK
28149 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28150 & '! program execution stopped..')
28153 IF (M1.LT.0) MO1 = NHKK+M1
28154 IF (M2.LT.0) MO2 = NHKK+M2
28157 JMOHKK(1,NHKK) = MO1
28158 JMOHKK(2,NHKK) = MO2
28162 IDXRES(NHKK) = IDXR
28164 ** here we need to do something..
28165 IF (ID.EQ.88888) THEN
28166 IDMO1 = ABS(IDHKK(MO1))
28167 IDMO2 = ABS(IDHKK(MO2))
28168 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28169 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28170 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28171 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28175 IDBAM(NHKK) = IDT_ICIHAD(ID)
28177 IF (JDAHKK(1,MO1).NE.0) THEN
28178 JDAHKK(2,MO1) = NHKK
28180 JDAHKK(1,MO1) = NHKK
28184 IF (JDAHKK(1,MO2).NE.0) THEN
28185 JDAHKK(2,MO2) = NHKK
28187 JDAHKK(1,MO2) = NHKK
28190 C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28191 C PTOT = SQRT(PX**2+PY**2+PZ**2)
28192 C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28193 C AMRQ = AAM(IDBAM(NHKK))
28194 C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28195 C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28196 C & (PTOT.GT.ZERO)) THEN
28197 C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28198 CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28200 C PTOT1 = PTOT-DELTA
28201 C PX = PX*PTOT1/PTOT
28202 C PY = PY*PTOT1/PTOT
28203 C PZ = PZ*PTOT1/PTOT
28210 PTOT = SQRT( PX**2+PY**2+PZ**2 )
28211 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28212 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28213 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28215 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28216 C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28217 C & WRITE(LOUT,'(1X,A,G10.3)')
28218 C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28219 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28222 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28223 * special treatment for chains:
28224 * z coordinate of chain in Lab = pos. of target nucleon
28225 * time of chain-creation in Lab = time of passage of projectile
28226 * nucleus at pos. of taget nucleus
28227 C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28228 C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28229 VHKK(1,NHKK) = VHKK(1,MO2)
28230 VHKK(2,NHKK) = VHKK(2,MO2)
28231 VHKK(3,NHKK) = VHKK(3,MO2)
28232 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28233 C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28234 C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28235 WHKK(1,NHKK) = WHKK(1,MO1)
28236 WHKK(2,NHKK) = WHKK(2,MO1)
28237 WHKK(3,NHKK) = WHKK(3,MO1)
28238 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28242 VHKK(I,NHKK) = VHKK(I,MO1)
28243 WHKK(I,NHKK) = WHKK(I,MO1)
28247 VHKK(I,NHKK) = ZERO
28248 WHKK(I,NHKK) = ZERO
28256 *$ CREATE DT_CHASTA.FOR
28259 *===chasta=============================================================*
28261 SUBROUTINE DT_CHASTA(MODE)
28263 ************************************************************************
28264 * This subroutine performs CHAin STAtistics and checks sequence of *
28265 * partons in dtevt1 and sorts them with projectile partons coming *
28266 * first if necessary. *
28268 * This version dated 8.5.00 is written by S. Roesler. *
28269 ************************************************************************
28271 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28273 PARAMETER ( LINP = 10 ,
28280 PARAMETER (NMXHKK=200000)
28281 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28282 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28283 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28284 * extended event history
28285 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28286 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28288 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28289 PARAMETER (MAXCHN=10000)
28290 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28292 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28293 & CCHTYP(9),ICHSTA(10),ITOT(10)
28294 DATA ICHCFG /1800*0/
28295 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28296 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28297 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28298 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28299 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28300 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28301 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28302 & 'ad aq',' d ad','ad d ',' g g '/
28306 IF (MODE.EQ.-1) THEN
28309 * loop over DTEVT1 and analyse chain configurations
28311 ELSEIF (MODE.EQ.0) THEN
28312 DO 21 IDX=NPOINT(3),NHKK
28313 IDCHK = IDHKK(IDX)/10000
28314 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28315 & (IDHKK(IDX).NE.80000).AND.
28316 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28317 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28318 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28323 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28324 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28326 IMO1 = IST1-10*IMO1
28328 IMO2 = IST2-10*IMO2
28329 * swop parton entries if necessary since we need projectile partons
28330 * to come first in the common
28331 IF (IMO1.GT.IMO2) THEN
28332 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28334 I0 = JMOHKK(1,IDX)-1+K
28335 I1 = JMOHKK(2,IDX)+1-K
28337 ISTHKK(I0) = ISTHKK(I1)
28340 IDHKK(I0) = IDHKK(I1)
28342 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28343 & JDAHKK(1,JMOHKK(1,I0)) = I1
28344 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28345 & JDAHKK(2,JMOHKK(1,I0)) = I1
28346 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28347 & JDAHKK(1,JMOHKK(2,I0)) = I1
28348 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28349 & JDAHKK(2,JMOHKK(2,I0)) = I1
28350 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28351 & JDAHKK(1,JMOHKK(1,I1)) = I0
28352 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28353 & JDAHKK(2,JMOHKK(1,I1)) = I0
28354 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28355 & JDAHKK(1,JMOHKK(2,I1)) = I0
28356 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28357 & JDAHKK(2,JMOHKK(2,I1)) = I0
28358 ITMP = JMOHKK(1,I0)
28359 JMOHKK(1,I0) = JMOHKK(1,I1)
28360 JMOHKK(1,I1) = ITMP
28361 ITMP = JMOHKK(2,I0)
28362 JMOHKK(2,I0) = JMOHKK(2,I1)
28363 JMOHKK(2,I1) = ITMP
28364 ITMP = JDAHKK(1,I0)
28365 JDAHKK(1,I0) = JDAHKK(1,I1)
28366 JDAHKK(1,I1) = ITMP
28367 ITMP = JDAHKK(2,I0)
28368 JDAHKK(2,I0) = JDAHKK(2,I1)
28369 JDAHKK(2,I1) = ITMP
28374 PHKK(J,I0) = PHKK(J,I1)
28375 VHKK(J,I0) = VHKK(J,I1)
28376 WHKK(J,I0) = WHKK(J,I1)
28382 PHKK(5,I0) = PHKK(5,I1)
28385 IDRES(I0) = IDRES(I1)
28388 IDXRES(I0) = IDXRES(I1)
28391 NOBAM(I0) = NOBAM(I1)
28394 IDBAM(I0) = IDBAM(I1)
28397 IDCH(I0) = IDCH(I1)
28400 IHIST(1,I0) = IHIST(1,I1)
28403 IHIST(2,I0) = IHIST(2,I1)
28407 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28408 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28410 * parton 1 (projectile side)
28411 IF (IST1.EQ.21) THEN
28413 ELSEIF (IST1.EQ.22) THEN
28415 ELSEIF (IST1.EQ.31) THEN
28417 ELSEIF (IST1.EQ.32) THEN
28419 ELSEIF (IST1.EQ.41) THEN
28421 ELSEIF (IST1.EQ.42) THEN
28423 ELSEIF (IST1.EQ.51) THEN
28425 ELSEIF (IST1.EQ.52) THEN
28427 ELSEIF (IST1.EQ.61) THEN
28429 ELSEIF (IST1.EQ.62) THEN
28433 c & ' CHASTA: unknown parton status flag (',
28434 c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28437 ID = IDHKK(JMOHKK(1,IDX))
28438 IF (ABS(ID).LE.4) THEN
28444 ELSEIF (ABS(ID).GE.1000) THEN
28450 ELSEIF (ID.EQ.21) THEN
28454 & ' CHASTA: inconsistent parton identity (',
28455 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28459 * parton 2 (target side)
28460 IF (IST2.EQ.21) THEN
28462 ELSEIF (IST2.EQ.22) THEN
28464 ELSEIF (IST2.EQ.31) THEN
28466 ELSEIF (IST2.EQ.32) THEN
28468 ELSEIF (IST2.EQ.41) THEN
28470 ELSEIF (IST2.EQ.42) THEN
28472 ELSEIF (IST2.EQ.51) THEN
28474 ELSEIF (IST2.EQ.52) THEN
28476 ELSEIF (IST2.EQ.61) THEN
28478 ELSEIF (IST2.EQ.62) THEN
28482 c & ' CHASTA: unknown parton status flag (',
28483 c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28486 ID = IDHKK(JMOHKK(2,IDX))
28487 IF (ABS(ID).LE.4) THEN
28493 ELSEIF (ABS(ID).GE.1000) THEN
28499 ELSEIF (ID.EQ.21) THEN
28503 & ' CHASTA: inconsistent parton identity (',
28504 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28509 ITYPE = ICHTYP(ITYP1,ITYP2)
28510 IF (ITYPE.NE.0) THEN
28511 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28512 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28513 ICHCFG(IDX1,IDX2,ITYPE,2) =
28514 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28517 IF (NCHAIN.GT.MAXCHN) THEN
28518 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28522 IDXCHN(1,NCHAIN) = IDX
28523 IDXCHN(2,NCHAIN) = ITYPE
28526 & ' CHASTA: inconsistent chain at entry ',IDX
28532 * write statistics to output unit
28534 ELSEIF (MODE.EQ.1) THEN
28535 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28537 WRITE(LOUT,'(/,2A)')
28538 & ' -----------------------------------------',
28539 & '------------------------------------'
28541 & ' p\\t 21 22 31 32 41',
28542 & ' 42 51 52 61 62'
28544 & ' -----------------------------------------',
28545 & '------------------------------------'
28549 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28552 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28556 ISUM = ISUM+ICHCFG(I,J,K,1)
28559 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28560 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28562 C WRITE(LOUT,'(2A)')
28563 C & ' -----------------------------------------',
28564 C & '-------------------------------'
28568 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28574 *$ CREATE PHO_PHIST.FOR
28577 *===pohist=============================================================*
28579 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28581 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28584 PARAMETER ( LINP = 10 ,
28587 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28588 * Glauber formalism: cross sections
28589 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28590 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28591 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28592 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28593 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28594 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28595 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28596 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28597 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28598 & BSLOPE,NEBINI,NQBINI
28601 IF (IMODE.EQ.10) THEN
28605 IF (ABS(IMODE).LT.1000) THEN
28606 * PHOJET-statistics
28607 C CALL POHISX(IMODE,WEIGHT)
28608 IF (IMODE.EQ.-1) THEN
28610 XSTOT(1,1,1) = WEIGHT
28612 IF (IMODE.EQ. 1) MODE = 2
28613 IF (IMODE.EQ.-2) MODE = 3
28614 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28615 C IF (MODE.EQ.3) WRITE(LOUT,*)
28616 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28617 CALL DT_HISTOG(MODE)
28618 CALL DT_USRHIS(MODE)
28620 * DTUNUC-statistics
28622 C IF (MODE.EQ.3) WRITE(LOUT,*)
28623 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28624 CALL DT_HISTOG(MODE)
28625 CALL DT_USRHIS(MODE)
28631 *$ CREATE DT_SWPPHO.FOR
28634 *===swppho=============================================================*
28636 SUBROUTINE DT_SWPPHO(ILAB)
28638 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28640 PARAMETER ( LINP = 10 ,
28643 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28648 PARAMETER (NMXHKK=200000)
28649 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28650 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28651 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28652 * extended event history
28653 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28654 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28656 * flags for input different options
28657 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28658 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28659 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28660 * properties of photon/lepton projectiles
28661 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28664 C PARAMETER (NMXHEP=2000)
28665 C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28666 C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28667 C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28668 C COMMON /PLASAV/ PLAB
28670 C standard particle data interface
28672 PARAMETER (NMXHEP=4000)
28673 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28674 DOUBLE PRECISION PHEP,VHEP
28675 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28676 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28677 & VHEP(4,NMXHEP),NSD1, NSD2, NDD
28678 C extension to standard particle data interface (PHOJET specific)
28679 INTEGER IMPART,IPHIST,ICOLOR
28680 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28681 C global event kinematics and particle IDs
28682 INTEGER IFPAP,IFPAB
28683 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28684 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28688 DATA LSTART /.TRUE./
28690 C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28691 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28695 IDP = IDT_ICIHAD(IFPAP(1))
28696 IDT = IDT_ICIHAD(IFPAP(2))
28698 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28707 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28709 IF (ISTHEP(I).EQ.1) THEN
28712 IDHKK(NHKK) = IDHEP(I)
28718 PHKK(K,NHKK) = PHEP(K,I)
28719 VHKK(K,NHKK) = ZERO
28720 WHKK(K,NHKK) = ZERO
28722 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28723 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28724 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28725 PHKK(5,NHKK) = PHEP(5,I)
28729 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28737 *$ CREATE DT_HISTOG.FOR
28740 *===histog=============================================================*
28742 SUBROUTINE DT_HISTOG(MODE)
28744 ************************************************************************
28745 * This version dated 25.03.96 is written by S. Roesler *
28746 ************************************************************************
28748 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28750 PARAMETER ( LINP = 10 ,
28757 PARAMETER (NMXHKK=200000)
28758 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28759 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28760 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28761 * extended event history
28762 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28763 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28765 * event flag used for histograms
28766 COMMON /DTNORM/ ICEVT,IEVHKK
28767 * flags for activated histograms
28768 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28773 *------------------------------------------------------------------
28777 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28778 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28781 *------------------------------------------------------------------
28782 * filling of histogram with event-record
28787 CALL DT_SWPFSP(I,LFSP,LRNL)
28789 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28790 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28792 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28794 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28797 *------------------------------------------------------------------
28800 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28801 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28806 *$ CREATE DT_SWPFSP.FOR
28809 *===swpfsp=============================================================*
28811 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28813 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28815 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28816 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28818 & BOG =TWOPI/360.0D0)
28821 PARAMETER (NMXHKK=200000)
28822 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28823 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28824 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28825 * extended event history
28826 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28827 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28829 * particle properties (BAMJET index convention)
28831 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28832 & IICH(210),IIBAR(210),K1(210),K2(210)
28833 * Lorentz-parameters of the current interaction
28834 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28835 & UMO,PPCM,EPROJ,PPROJ
28836 * flags for input different options
28837 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28838 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28839 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28840 * (original name: PAREVT)
28841 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28842 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28843 PARAMETER ( NALLWP = 39 )
28844 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28845 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28846 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28847 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28848 * temporary storage for one final state particle
28849 LOGICAL LFRAG,LGREY,LBLACK
28850 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28851 & SINTHE,COSTHE,THETA,THECMS,
28852 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28853 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28854 & LFRAG,LGREY,LBLACK
28862 IF (LEVPRT) ISTRNL = 1001
28864 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28868 IF (IDHKK(IDX).LT.80000) THEN
28870 IBARY = IIBAR(IDBJT)
28871 ICHAR = IICH(IDBJT)
28873 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28876 ICHAR = IDXRES(IDX)
28877 AMASS = PHKK(5,IDX)
28879 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28880 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28881 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28882 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28883 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28893 PTOT = SQRT(PT2+PZ**2)
28894 SINTHE = PT/MAX(PTOT,TINY14)
28895 COSTHE = PZ/MAX(PTOT,TINY14)
28896 IF (COSTHE.GT.ONE) THEN
28898 ELSEIF (COSTHE.LT.-ONE) THEN
28899 THETA = TWOPI/2.0D0
28901 THETA = ACOS(COSTHE)
28904 **sr 15.4.96 new E_t-definition
28905 IF (IBARY.GT.0) THEN
28907 ELSEIF (IBARY.LT.0) THEN
28908 ET = (EKIN+TWO*AMASS)*SINTHE
28913 XLAB = PZ/MAX(PPROJ,TINY14)
28914 C XLAB = PE/MAX(EPROJ,TINY14)
28915 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28916 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28919 IF (PMINUS.GT.TINY14) THEN
28920 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28924 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28925 ETA = -LOG(TAN(THETA/TWO))
28929 IF (IFRAME.EQ.1) THEN
28930 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28931 PPLUS = EECMS+PZCMS
28932 PMINUS = EECMS-PZCMS
28933 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28934 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28938 PTOTCM = SQRT(PT2+PZCMS**2)
28939 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28940 IF (COSTH.GT.ONE) THEN
28942 ELSEIF (COSTH.LT.-ONE) THEN
28943 THECMS = TWOPI/2.0D0
28945 THECMS = ACOS(COSTH)
28947 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28948 ETACMS = -LOG(TAN(THECMS/TWO))
28952 XF = PZCMS/MAX(PPCM,TINY14)
28953 THECMS = THECMS/BOG
28964 * set flag for "grey/black"
28968 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28969 IF (MULDEF.EQ.1) THEN
28971 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28972 & (EK.LE.375.0D-3) ).OR.
28973 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28974 & (EK.LE. 56.0D-3) ).OR.
28975 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28976 & (EK.LE. 56.0D-3) ).OR.
28977 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28978 & (EK.LE.198.0D-3) ).OR.
28979 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28980 & (EK.LE.198.0D-3) ).OR.
28981 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28982 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28983 & (IDBJT.NE.16).AND.
28984 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28986 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28987 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28988 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28989 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28990 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28991 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28992 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28993 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
28997 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28998 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
29001 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
29007 ICHAR = IDXRES(IDX)
29008 AMASS = PHKK(5,IDX)
29015 PTOT = SQRT(PT2+PZ**2)
29016 SINTHE = PT/MAX(PTOT,TINY14)
29017 COSTHE = PZ/MAX(PTOT,TINY14)
29018 IF (COSTHE.GT.ONE) THEN
29020 ELSEIF (COSTHE.LT.-ONE) THEN
29021 THETA = TWOPI/2.0D0
29023 THETA = ACOS(COSTHE)
29026 **sr 15.4.96 new E_t-definition
29030 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
29031 ETA = -LOG(TAN(THETA/TWO))
29043 *$ CREATE DT_HIMULT.FOR
29046 *===himult=============================================================*
29048 SUBROUTINE DT_HIMULT(MODE)
29050 ************************************************************************
29051 * Tables of average energies/multiplicities. *
29052 * This version dated 30.08.2000 is written by S. Roesler *
29053 ************************************************************************
29055 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29057 PARAMETER ( LINP = 10 ,
29060 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29062 PARAMETER (SWMEXP=1.7D0)
29064 CHARACTER*8 ANAMEH(4)
29066 * particle properties (BAMJET index convention)
29068 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29069 & IICH(210),IIBAR(210),K1(210),K2(210)
29070 * temporary storage for one final state particle
29071 LOGICAL LFRAG,LGREY,LBLACK
29072 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29073 & SINTHE,COSTHE,THETA,THECMS,
29074 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29075 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29076 & LFRAG,LGREY,LBLACK
29077 * event flag used for histograms
29078 COMMON /DTNORM/ ICEVT,IEVHKK
29079 * Lorentz-parameters of the current interaction
29080 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29081 & UMO,PPCM,EPROJ,PPROJ
29083 PARAMETER (NOPART=210)
29084 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29085 & AVPT(4,NOPART),IAVPT(4,NOPART)
29086 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
29090 *------------------------------------------------------------------
29105 *------------------------------------------------------------------
29106 * filling of histogram with event-record
29108 IF (PE.LT.0.0D0) THEN
29109 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
29112 IF (.NOT.LFRAG) THEN
29114 IF (LGREY) IVEL = 3
29115 IF (LBLACK) IVEL = 4
29116 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
29117 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
29118 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
29119 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
29120 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
29121 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29122 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
29123 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29124 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
29125 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29126 IF (IDBJT.LT.116) THEN
29127 * total energy, multiplicity
29128 AVE(1,30) = AVE(1,30) +PE
29129 AVE(IVEL,30) = AVE(IVEL,30)+PE
29130 AVPT(1,30) = AVPT(1,30) +PT
29131 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
29132 IAVPT(1,30) = IAVPT(1,30) +1
29133 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29134 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
29135 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
29136 AVMULT(1,30) = AVMULT(1,30) +ONE
29137 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29138 * charged energy, multiplicity
29139 IF (ICHAR.LT.0) THEN
29140 AVE(1,26) = AVE(1,26) +PE
29141 AVE(IVEL,26) = AVE(IVEL,26)+PE
29142 AVPT(1,26) = AVPT(1,26) +PT
29143 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
29144 IAVPT(1,26) = IAVPT(1,26) +1
29145 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29146 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
29147 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
29148 AVMULT(1,26) = AVMULT(1,26) +ONE
29149 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29151 IF (ICHAR.NE.0) THEN
29152 AVE(1,27) = AVE(1,27) +PE
29153 AVE(IVEL,27) = AVE(IVEL,27)+PE
29154 AVPT(1,27) = AVPT(1,27) +PT
29155 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
29156 IAVPT(1,27) = IAVPT(1,27) +1
29157 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29158 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
29159 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
29160 AVMULT(1,27) = AVMULT(1,27) +ONE
29161 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29168 *------------------------------------------------------------------
29172 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29173 & 29X,'---------------------',/)
29174 IF (MULDEF.EQ.1) THEN
29175 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29179 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29180 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
29181 & ,F4.2,' black: beta < ',F4.2,/)
29183 WRITE(LOUT,3003) SWMEXP
29184 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
29185 & 13X,'| total fast',
29186 C & ' grey black K f(',F3.1,')',/,1X,
29187 & ' grey black <pt> f(',F3.1,')',/,1X,
29188 & '------------+--------------',
29189 & '-------------------------------------------------')
29192 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29193 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29194 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29195 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29198 WRITE(LOUT,3004) ANAME(I),I,
29199 & AVMULT(1,I),AVMULT(2,I),
29200 & AVMULT(3,I),AVMULT(4,I),
29201 C & AVE(1,I),AVSWM(1,I)
29202 & AVPT(1,I),AVSWM(1,I)
29203 ELSEIF (I.LE.119) THEN
29204 WRITE(LOUT,3004) ANAMEH(I-115),I,
29205 & AVMULT(1,I),AVMULT(2,I),
29206 & AVMULT(3,I),AVMULT(4,I),
29207 C & AVE(1,I),AVSWM(1,I)
29208 & AVPT(1,I),AVSWM(1,I)
29210 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29213 C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29214 C & AVMULT(3,27)+AVMULT(4,27)
29220 *$ CREATE DT_HISTAT.FOR
29223 *===histat=============================================================*
29225 SUBROUTINE DT_HISTAT(IDX,MODE)
29227 ************************************************************************
29228 * This version dated 26.02.96 is written by S. Roesler *
29230 * Last change 27.12.2006 by S. Roesler. *
29231 ************************************************************************
29233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29235 PARAMETER ( LINP = 10 ,
29238 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29239 PARAMETER (NDIM=199)
29242 PARAMETER (NMXHKK=200000)
29243 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29244 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29245 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29246 * extended event history
29247 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29248 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29250 * particle properties (BAMJET index convention)
29252 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29253 & IICH(210),IIBAR(210),K1(210),K2(210)
29254 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29255 * Glauber formalism: cross sections
29256 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29257 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29258 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29259 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29260 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29261 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29262 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29263 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29264 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29265 & BSLOPE,NEBINI,NQBINI
29266 * emulsion treatment
29267 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29269 * properties of interacting particles
29270 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29271 * rejection counter
29272 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29273 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29274 & IREXCI(3),IRDIFF(2),IRINC
29275 * statistics: residual nuclei
29276 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29277 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29278 & NINCST(2,4),NINCEV(2),
29279 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29280 & NRESPB(2),NRESCH(2),NRESEV(4),
29281 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29283 * parameter for intranuclear cascade
29285 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29286 * (original name: PAREVT)
29287 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29288 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29289 PARAMETER ( NALLWP = 39 )
29290 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29291 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29292 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29293 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29294 * (original name: FRBKCM)
29295 PARAMETER ( MXFFBK = 6 )
29296 PARAMETER ( MXZFBK = 9 )
29297 PARAMETER ( MXNFBK = 10 )
29298 PARAMETER ( MXAFBK = 16 )
29299 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29300 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29301 PARAMETER ( NXAFBK = MXAFBK + 1 )
29302 PARAMETER ( MXPSST = 300 )
29303 PARAMETER ( MXPSFB = 41000 )
29304 LOGICAL LFRMBK, LNCMSS
29305 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29306 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29307 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29308 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29309 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29310 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29311 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29312 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29313 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
29314 * (original name: INPFLG)
29315 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29316 * temporary storage for one final state particle
29317 LOGICAL LFRAG,LGREY,LBLACK
29318 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29319 & SINTHE,COSTHE,THETA,THECMS,
29320 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29321 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29322 & LFRAG,LGREY,LBLACK
29323 * event flag used for histograms
29324 COMMON /DTNORM/ ICEVT,IEVHKK
29325 * statistics: double-Pomeron exchange
29326 COMMON /DTFLG2/ INTFLG,IPOPO
29328 DIMENSION EMUSAM(NCOMPX)
29330 CHARACTER*13 CMSG(3)
29331 DATA CMSG /'not requested','not requested','not requested'/
29333 GOTO (1,2,3,4,5) MODE
29335 *------------------------------------------------------------------
29338 * emulsion treatment
29339 IF (NCOMPO.GT.0) THEN
29344 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29365 IF (J.LE.2) NINCHR(I,J) = 0
29366 IF (J.LE.3) NINCCO(I,J) = 0
29367 IF (J.LE.4) NINCST(I,J) = 0
29376 **dble Po statistics.
29380 *------------------------------------------------------------------
29381 * filling of histogram with event-record
29383 IF (IST.EQ.-1) THEN
29384 IF (.NOT.LFRAG) THEN
29385 IF (IDPDG.EQ.2212) THEN
29386 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29387 ELSEIF (IDPDG.EQ.2112) THEN
29388 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29389 ELSEIF (IDPDG.EQ.22) THEN
29390 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29391 ELSEIF (IDPDG.EQ.80000) THEN
29392 IF (IDBJT.EQ.116) THEN
29393 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29394 ELSEIF (IDBJT.EQ.117) THEN
29395 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29396 ELSEIF (IDBJT.EQ.118) THEN
29397 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29398 ELSEIF (IDBJT.EQ.119) THEN
29399 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29403 * heavy fragments (here: fission products only)
29404 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29405 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29406 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29408 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29409 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29413 *------------------------------------------------------------------
29417 **dble Po statistics.
29418 C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29419 C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29420 C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29422 * emulsion treatment
29423 IF (NCOMPO.GT.0) THEN
29425 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29426 & 22X,'----------------------------',/,/,19X,
29427 & 'mass charge fraction',/,39X,
29428 & 'input treated',/)
29430 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29431 & EMUSAM(I)/DBLE(ICEVT)
29432 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29436 * i.n.c. statistics: output
29437 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29438 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29439 & 22X,'---------------------------------',/,/,1X,
29440 & 'no. of events for normalization: (accepted final events,',
29441 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29442 & /,1X,'no. of rejected events due to intranuclear',
29443 & ' cascade',15X,I6,/)
29444 ICEV = MAX(ICEVT,1)
29446 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29448 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29449 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29450 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29451 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29452 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29453 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29454 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29455 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29456 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29457 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29458 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29459 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29460 & /,1X,'maximum no. of generations treated (maximum allowed:'
29461 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29462 & ' interactions in proj./ target (mean per evt1)',
29463 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29464 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29465 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29466 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29467 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29468 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29469 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29470 & 'evaporation',/,22X,'-----------------------------',
29471 & '------------',/,/,1X,'no. of events for normal.: ',
29472 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29473 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29474 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29477 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29478 ICEV = MAX(NRESEV(2),1)
29480 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29481 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29482 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29483 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29484 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29485 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29486 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29487 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29488 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29489 & 'proj. / target',/,/,8X,'total number of particles',15X,
29490 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29491 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29492 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29493 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29494 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29496 * evaporation / fission / fragmentation statistics: output
29497 ICEV = MAX(NRESEV(2),1)
29498 ICEV1 = MAX(NRESEV(4),1)
29500 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29502 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29504 IF (IFISS.EQ.1) CMSG(1) = 'requested '
29505 IF (LFRMBK) CMSG(2) = 'requested '
29506 IF (LDEEXG) CMSG(3) = 'requested '
29509 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29510 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29511 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29512 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29513 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29514 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29515 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29516 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29517 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29518 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29519 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29520 & 'deexcitation:',2X,A13,/,/,
29521 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29522 & 'proj. / target',/,/,8X,'total number of evap. particles',
29523 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29524 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29525 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29526 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29527 & 'heavy fragments',25X,2F9.3,/)
29528 IF (IFISS.EQ.1) THEN
29529 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29530 & NEVAFI(2,1),NEVAFI(2,2),
29531 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29532 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29533 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29534 & 12X,'out of which fission occured',8X,2I9,/,
29535 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29537 C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29539 C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29540 C & ' proj. / target',/)
29542 C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29543 C WRITE(LOUT,3009) I,
29544 C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29545 C3009 FORMAT(38X,I3,3X,2E12.3)
29549 C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29550 C & ' proj. / target',/)
29552 C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29553 C WRITE(LOUT,3011) I,
29554 C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29555 C3011 FORMAT(38X,I3,3X,2E12.3)
29562 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29563 & 'Evaporation: not requested',/)
29567 *------------------------------------------------------------------
29568 * filling of histogram with event-record
29570 * emulsion treatment
29571 IF (NCOMPO.GT.0) THEN
29573 IF (IT.EQ.IEMUMA(I)) THEN
29574 EMUSAM(I) = EMUSAM(I)+ONE
29578 NINCGE = NINCGE+MAXGEN
29580 **dble Po statistics.
29581 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29584 *------------------------------------------------------------------
29585 * filling of histogram with event-record
29587 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29588 IB = IIBAR(IDBAM(IDX))
29589 IC = IICH(IDBAM(IDX))
29591 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29592 NINCST(J,1) = NINCST(J,1)+1
29593 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29594 NINCST(J,2) = NINCST(J,2)+1
29595 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29596 NINCST(J,3) = NINCST(J,3)+1
29597 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29598 NINCST(J,4) = NINCST(J,4)+1
29600 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29601 NINCWO(1) = NINCWO(1)+1
29602 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29603 NINCWO(2) = NINCWO(2)+1
29604 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29608 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29609 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29611 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29617 *$ CREATE DT_NEWHGR.FOR
29620 *===newhgr=============================================================*
29622 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29624 ************************************************************************
29626 * Histogram initialization. *
29628 * input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29630 * IBIN > 0 number of bins in equidistant lin. binning *
29631 * = -1 reset histograms *
29632 * < -1 |IBIN| number of bins in equidistant log. *
29633 * binning or log. binning in user def. struc. *
29634 * XLIMB(*) user defined bin structure *
29636 * The bin structure is sensitive to *
29637 * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29638 * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29639 * XLIMB, IBIN if XLIM3 < 0 *
29642 * output: IREFN histogram index *
29643 * (= -1 for inconsistent histogr. request) *
29645 * This subroutine is based on a original version by R. Engel. *
29646 * This version dated 22.4.95 is written by S. Roesler. *
29647 ************************************************************************
29649 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29651 PARAMETER ( LINP = 10 ,
29657 PARAMETER (ZERO = 0.0D0,
29663 PARAMETER (NHIS=150, NDIM=250)
29664 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29665 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29666 * auxiliary common for histograms
29667 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29669 DATA LSTART /.TRUE./
29671 * reset histogram counter
29672 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29674 IF (IBIN.EQ.-1) RETURN
29679 * check for maximum number of allowed histograms
29680 IF (IHIS.GT.NHIS) THEN
29681 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29682 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29683 & I4,') exceeds array size (',I4,')',/,21X,
29684 & 'histogram',I3,' skipped!')
29689 IBINS(IHIS) = ABS(IBIN)
29690 * check requested number of bins
29691 IF (IBINS(IHIS).GE.NDIM) THEN
29692 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29693 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29694 & I3,') exceeds array size (',I3,')',/,21X,
29695 & 'and will be reset to ',I3)
29698 IF (IBINS(IHIS).EQ.0) THEN
29699 WRITE(LOUT,1001) IBIN,IHIS
29700 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29701 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29705 * initialize arrays
29708 HIST(K,IHIS,I) = ZERO
29709 HIST(K+3,IHIS,I) = ZERO
29710 TMPHIS(K,IHIS,I) = ZERO
29712 HIST(7,IHIS,I) = ZERO
29714 DENTRY(1,IHIS)= ZERO
29715 DENTRY(2,IHIS)= ZERO
29717 UNDERF(IHIS) = ZERO
29718 TMPUFL(IHIS) = ZERO
29719 TMPOFL(IHIS) = ZERO
29721 * bin str. sensitive to lower edge, bin size, and numb. of bins
29722 IF (XLIM3.GT.ZERO) THEN
29723 DO 3 K=1,IBINS(IHIS)+1
29724 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29727 * bin str. sensitive to lower/upper edge and numb. of bins
29728 ELSEIF (XLIM3.EQ.ZERO) THEN
29730 IF (IBIN.GT.0) THEN
29733 IF (XLIM2.LE.XLIM1) THEN
29734 WRITE(LOUT,1002) XLIM1,XLIM2
29735 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29736 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29740 ELSEIF (IBIN.LT.-1) THEN
29741 * logarithmic binning
29742 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29743 WRITE(LOUT,1004) XLIM1,XLIM2
29744 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29745 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29748 IF (XLIM2.LE.XLIM1) THEN
29749 WRITE(LOUT,1005) XLIM1,XLIM2
29750 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29751 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29754 XLOW = LOG10(XLIM1)
29758 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29759 DO 4 K=1,IBINS(IHIS)+1
29760 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29763 * user defined bin structure
29764 DO 5 K=1,IBINS(IHIS)+1
29765 IF (IBIN.GT.0) THEN
29766 HIST(1,IHIS,K) = XLIMB(K)
29768 ELSEIF (IBIN.LT.-1) THEN
29769 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29775 * histogram accepted
29785 *$ CREATE DT_FILHGR.FOR
29788 *===filhgr=============================================================*
29790 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29792 ************************************************************************
29794 * Scoring for histogram IHIS. *
29796 * This subroutine is based on a original version by R. Engel. *
29797 * This version dated 23.4.95 is written by S. Roesler. *
29798 ************************************************************************
29800 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29802 PARAMETER ( LINP = 10 ,
29806 PARAMETER (ZERO = 0.0D0,
29811 PARAMETER (NHIS=150, NDIM=250)
29812 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29813 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29814 * auxiliary common for histograms
29815 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29822 * dump content of temorary arrays into histograms
29823 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29824 CALL DT_EVTHIS(IDUM)
29828 * check histogram index
29829 IF (IHIS.EQ.-1) RETURN
29830 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29831 C WRITE(LOUT,1000) IHIS,IHISL
29832 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29833 & ' out of range (1..',I3,')')
29837 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29838 * bin structure not explicitly given
29839 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29840 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29841 IF (X.LT.HIST(1,IHIS,1)) THEN
29844 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29847 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29848 * user defined bin structure
29849 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29850 IF (X.LT.HIST(1,IHIS,1)) THEN
29852 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29855 * binary sort algorithm
29857 KMAX = IBINS(IHIS)+1
29859 IF ((KMAX-KMIN).EQ.1) GOTO 2
29861 IF (X.LE.HIST(1,IHIS,KK)) THEN
29873 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29879 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29880 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29881 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29882 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29883 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29885 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29887 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29889 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29895 *$ CREATE DT_EVTHIS.FOR
29898 *===evthis=============================================================*
29900 SUBROUTINE DT_EVTHIS(NEVT)
29902 ************************************************************************
29903 * Dump content of temorary histograms into /DTHIS1/. This subroutine *
29904 * is called after each event and for the last event before any call *
29906 * NEVT number of events dumped, this is only needed to *
29907 * get the normalization after the last event *
29908 * This version dated 23.4.95 is written by S. Roesler. *
29909 ************************************************************************
29911 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29913 PARAMETER ( LINP = 10 ,
29919 PARAMETER (ZERO = 0.0D0,
29924 PARAMETER (NHIS=150, NDIM=250)
29925 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29926 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29927 * auxiliary common for histograms
29928 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29938 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29940 HIST(2,I,J) = HIST(2,I,J)+ONE
29941 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29942 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29943 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29944 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29945 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29946 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29947 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29948 TMPHIS(1,I,J) = ZERO
29949 TMPHIS(2,I,J) = ZERO
29950 TMPHIS(3,I,J) = ZERO
29954 IF (TMPUFL(I).GT.ZERO) THEN
29955 UNDERF(I) = UNDERF(I)+ONE
29957 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29958 OVERF(I) = OVERF(I)+ONE
29962 DENTRY(1,I) = DENTRY(1,I)+ONE
29969 *$ CREATE DT_OUTHGR.FOR
29972 *===outhgr=============================================================*
29974 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29975 & ILOGY,INORM,NMODE)
29977 ************************************************************************
29979 * Plot histogram(s) to standard output unit *
29981 * I1..6 indices of histograms to be plotted *
29982 * CHEAD,IHEAD header string,integer *
29983 * NEVTS number of events *
29984 * FAC scaling factor *
29985 * ILOGY = 1 logarithmic y-axis *
29986 * INORM normalization *
29987 * = 0 no further normalization (FAC is obsolete) *
29988 * = 1 per event and bin width *
29989 * = 2 per entry and bin width *
29990 * = 3 per bin entry *
29991 * = 4 per event and "bin width" x1^2...x2^2 *
29992 * = 5 per event and "log. bin width" ln x1..ln x2 *
29994 * MODE = 0 no output but normalization applied *
29995 * = 1 all valid histograms separately (small frame) *
29996 * all valid histograms separately (small frame) *
29997 * = -1 and tables as histograms *
29998 * = 2 all valid histograms (one plot, wide frame) *
29999 * all valid histograms (one plot, wide frame) *
30000 * = -2 and tables as histograms *
30003 * Note: All histograms to be plotted with one call to this *
30004 * subroutine and |MODE|=2 must have the same bin structure! *
30005 * There is no test included ensuring this fact. *
30007 * This version dated 23.4.95 is written by S. Roesler. *
30008 ************************************************************************
30010 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30012 PARAMETER ( LINP = 10 ,
30018 PARAMETER (ZERO = 0.0D0,
30029 PARAMETER (NHIS=150, NDIM=250)
30030 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30031 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30033 PARAMETER (NDIM2 = 2*NDIM)
30034 DIMENSION XX(NDIM2),YY(NDIM2)
30036 PARAMETER (NHISTO = 6)
30037 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30040 CHARACTER*43 CNORM(0:8)
30041 DATA CNORM /'no further normalization ',
30042 & 'per event and bin width ',
30043 & 'per entry1 and bin width ',
30044 & 'per bin entry ',
30045 & 'per event and "bin width" x1^2...x2^2 ',
30046 & 'per event and "log. bin width" ln x1..ln x2',
30048 & 'per bin entry1 ',
30049 & 'per entry2 and bin width '/
30060 * initialization if "wide frame" is requested
30061 IF (ABS(MODE).EQ.2) THEN
30071 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30073 * check histogram indices
30076 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30077 IF (ISWI(IDX1(I)).NE.0) THEN
30078 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30080 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30081 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
30082 & ' histogram ',I3,/,21X,'underflows:',F10.0,
30083 & ' overflows: ',F10.0)
30093 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30097 * check normalization request
30098 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30099 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30100 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30101 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30102 WRITE(LOUT,1002) NEVTS,INORM,FAC
30103 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30104 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30109 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30111 * apply normalization
30116 IF (ISWI(I).EQ.1) THEN
30117 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30118 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30119 & ' to',2X,E10.4,',',2X,I3,' bins')
30120 ELSEIF (ISWI(I).EQ.2) THEN
30121 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30123 1007 FORMAT(1X,'user defined bin structure')
30124 ELSEIF (ISWI(I).EQ.3) THEN
30126 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30127 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30128 & ' to',2X,E10.4,',',2X,I3,' bins')
30129 ELSEIF (ISWI(I).EQ.4) THEN
30131 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30134 WRITE(LOUT,1008) ISWI(I)
30135 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30137 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30138 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30139 & ' overfl.:',F8.0)
30140 WRITE(LOUT,1009) CNORM(INORM)
30141 1009 FORMAT(1X,'normalization: ',A,/)
30144 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30147 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30148 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30149 1006 FORMAT(1X,5E11.3)
30152 XX(II-1) = HIST(1,I,K)
30153 XX(II) = HIST(1,I,K+1)
30158 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30159 & XX1(K,N) = LOG10(XMEAN)
30164 IF (ABS(MODE).EQ.1) THEN
30166 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30167 IF(ILOGY.EQ.1) THEN
30168 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30170 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30177 IF (ABS(MODE).EQ.2) THEN
30178 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30179 NSIZE = NDIM*NHISTO
30180 DXLOW = HIST(1,IDX(1),1)
30181 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30186 IF (YY1(J,I).LT.YLOW) THEN
30187 IF (ILOGY.EQ.1) THEN
30188 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30193 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30196 DY = (YHI-YLOW)/DBLE(NDIM)
30197 IF (DY.LE.ZERO) THEN
30198 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30199 & 'OUTHGR: warning! zero bin width for histograms ',
30200 & IDX,': ',YLOW,YHI
30203 IF (ILOGY.EQ.1) THEN
30205 DY = (LOG10(YHI)-YLOW)/100.0D0
30208 IF (YY1(J,I).LE.ZERO) THEN
30211 YY1(J,I) = LOG10(YY1(J,I))
30216 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30222 *$ CREATE DT_GETBIN.FOR
30225 *===getbin=============================================================*
30227 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30228 & XMEAN,YMEAN,YERR)
30230 ************************************************************************
30231 * This version dated 23.4.95 is written by S. Roesler. *
30232 ************************************************************************
30234 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30236 PARAMETER ( LINP = 10 ,
30240 PARAMETER (ZERO = 0.0D0,
30242 & TINY35 = 1.0D-35)
30245 PARAMETER (NHIS=150, NDIM=250)
30246 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30247 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30249 XLOW = HIST(1,IHIS,IBIN)
30250 XHI = HIST(1,IHIS,IBIN+1)
30251 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30255 IF (NORM.EQ.2) THEN
30257 NEVT = INT(DENTRY(1,IHIS))
30258 ELSEIF (NORM.EQ.3) THEN
30260 NEVT = INT(HIST(2,IHIS,IBIN))
30261 ELSEIF (NORM.EQ.4) THEN
30262 DX = XHI**2-XLOW**2
30264 ELSEIF (NORM.EQ.5) THEN
30265 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30267 ELSEIF (NORM.EQ.6) THEN
30270 ELSEIF (NORM.EQ.7) THEN
30272 NEVT = INT(HIST(7,IHIS,IBIN))
30273 ELSEIF (NORM.EQ.8) THEN
30275 NEVT = INT(DENTRY(2,IHIS))
30280 IF (ABS(DX).LT.TINY35) DX = ONE
30282 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30283 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30284 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30285 YSUM = HIST(5,IHIS,IBIN)
30286 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30287 C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30288 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30289 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30294 *$ CREATE DT_JOIHIS.FOR
30297 *===joihis=============================================================*
30299 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30301 ************************************************************************
30303 * Operation on histograms. *
30305 * input: IH1,IH2 histogram indices to be joined *
30306 * COPER character defining the requested operation, *
30307 * i.e. '+', '-', '*', '/' *
30308 * FAC1,FAC2 factors for joining, i.e. *
30309 * FAC1*histo1 COPER FAC2*histo2 *
30311 * This version dated 23.4.95 is written by S. Roesler. *
30312 ************************************************************************
30314 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30316 PARAMETER ( LINP = 10 ,
30322 PARAMETER (ZERO = 0.0D0,
30330 PARAMETER (NHIS=150, NDIM=250)
30331 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30332 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30334 PARAMETER (NDIM2 = 2*NDIM)
30335 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30337 CHARACTER*43 CNORM(0:6)
30338 DATA CNORM /'no further normalization ',
30339 & 'per event and bin width ',
30340 & 'per entry and bin width ',
30341 & 'per bin entry ',
30342 & 'per event and "bin width" x1^2...x2^2 ',
30343 & 'per event and "log. bin width" ln x1..ln x2',
30346 * check histogram indices
30347 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30348 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30349 WRITE(LOUT,1000) IH1,IH2,IHISL
30350 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30351 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30355 * check bin structure of histograms to be joined
30356 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30357 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30358 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30359 & ' and ',I3,' failed',/,21X,
30360 & 'due to different numbers of bins (',I3,',',I3,')')
30363 DO 1 K=1,IBINS(IH1)+1
30364 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30365 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30366 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30367 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30368 & 'X1,X2 = ',2E11.4)
30373 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30374 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30375 & 'operation ',A,/,11X,'and factors ',2E11.4)
30376 WRITE(LOUT,1004) CNORM(NORM)
30377 1004 FORMAT(1X,'normalization: ',A,/)
30379 DO 2 K=1,IBINS(IH1)
30380 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30381 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30384 XMEAN = OHALF*(XMEAN1+XMEAN2)
30385 IF (COPER.EQ.'+') THEN
30386 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30387 ELSEIF (COPER.EQ.'*') THEN
30388 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30389 ELSEIF (COPER.EQ.'/') THEN
30390 IF (YMEAN2.EQ.ZERO) THEN
30393 IF (FAC2.EQ.ZERO) FAC2 = ONE
30394 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30399 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30400 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30401 1006 FORMAT(1X,5E11.3)
30404 XX(II-1) = HIST(1,IH1,K)
30405 XX(II) = HIST(1,IH1,K+1)
30410 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30415 IF (ABS(MODE).EQ.1) THEN
30416 IBIN2 = 2*IBINS(IH1)
30417 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30418 IF(ILOGY.EQ.1) THEN
30419 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30421 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30426 IF (ABS(MODE).EQ.2) THEN
30427 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30429 DXLOW = HIST(1,IH1,1)
30430 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30434 IF (YY1(I).LT.YLOW) THEN
30435 IF (ILOGY.EQ.1) THEN
30436 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30441 IF (YY1(I).GT.YHI) YHI = YY1(I)
30443 DY = (YHI-YLOW)/DBLE(NDIM)
30444 IF (DY.LE.ZERO) THEN
30445 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30446 & 'JOIHIS: warning! zero bin width for histograms ',
30447 & IH1,IH2,': ',YLOW,YHI
30450 IF (ILOGY.EQ.1) THEN
30452 DY = (LOG10(YHI)-YLOW)/100.0D0
30454 IF (YY1(I).LE.ZERO) THEN
30457 YY1(I) = LOG10(YY1(I))
30461 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30467 WRITE(LOUT,1005) COPER
30468 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30474 *$ CREATE DT_XGRAPH.FOR
30477 *===qgraph=============================================================*
30479 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30480 C***********************************************************************
30482 C calculate quasi graphic picture with 25 lines and 79 columns
30483 C ranges will be chosen automatically
30485 C input N dimension of input fields
30486 C IARG number of curves (fields) to plot
30491 C This subroutine is written by R. Engel.
30492 C***********************************************************************
30493 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30496 PARAMETER ( LINP = 10 ,
30500 DIMENSION X(N),Y1(N),Y2(N)
30501 PARAMETER (EPS=1.D-30)
30502 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30504 CHARACTER COL(0:149,0:49)
30506 DATA SYMB /'0','e','z','#','x'/
30510 C*** automatic range fitting
30515 XMAX=MAX(X(I),XMAX)
30516 XMIN=MIN(X(I),XMIN)
30518 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30521 DO 1100 K=0,IZEIL-1
30523 IF (ITEST.EQ.IYRAST) THEN
30524 DO 1010 L=1,ISPALT-1
30529 DO 1020 L=0,ISPALT-1,IXRAST
30533 DO 1030 L=1,ISPALT-1
30536 DO 1040 L=0,ISPALT-1,IXRAST
30548 YMAX=MAX(Y1(I),YMAX)
30549 YMIN=MIN(Y1(I),YMIN)
30553 YMAX=MAX(Y2(I),YMAX)
30554 YMIN=MIN(Y2(I),YMIN)
30557 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30558 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30559 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30560 IF(YZOOM.LT.EPS) THEN
30561 WRITE(LOUT,'(1X,A)')
30562 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30571 L=NINT((X(K)-XMIN)/XZOOM)
30572 I=NINT((YMAX-Y1(K))/YZOOM)
30573 IF(ILAST.GE.0) THEN
30576 DO 55 II=0,LD,SIGN(1,LD)
30577 DO 66 KK=0,ID,SIGN(1,ID)
30578 COL(II+LLAST,KK+ILAST)=SYMB(1)
30593 L=NINT((X(K)-XMIN)/XZOOM)
30594 I=NINT((YMAX-Y2(K))/YZOOM)
30601 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30603 C*** write range of X
30605 XZOOM = (XMAX-XMIN)/DBLE(7)
30606 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30608 DO 1300 K=0,IZEIL-1
30609 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30610 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30611 110 FORMAT(1X,1PE9.2,70A1)
30614 C*** write range of X
30616 XZOOM = (XMAX-XMIN)/DBLE(7)
30617 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30618 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30619 120 FORMAT(6X,7(1PE10.3))
30622 *$ CREATE DT_XGLOGY.FOR
30625 *===qglogy=============================================================*
30627 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30628 C***********************************************************************
30630 C calculate quasi graphic picture with 25 lines and 79 columns
30631 C logarithmic y axis
30632 C ranges will be chosen automatically
30634 C input N dimension of input fields
30635 C IARG number of curves (fields) to plot
30640 C This subroutine is written by R. Engel.
30641 C***********************************************************************
30643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30646 PARAMETER ( LINP = 10 ,
30649 DIMENSION X(N),Y1(N),Y2(N)
30650 PARAMETER (EPS=1.D-30)
30651 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30653 CHARACTER COL(0:149,0:49)
30654 PARAMETER (DEPS = 1.D-10)
30656 DATA SYMB /'0','e','z','#','x'/
30660 C*** automatic range fitting
30665 XMAX=MAX(X(I),XMAX)
30666 XMIN=MIN(X(I),XMIN)
30668 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30671 DO 1100 K=0,IZEIL-1
30673 IF (ITEST.EQ.IYRAST) THEN
30674 DO 1010 L=1,ISPALT-1
30679 DO 1020 L=0,ISPALT-1,IXRAST
30683 DO 1030 L=1,ISPALT-1
30686 DO 1040 L=0,ISPALT-1,IXRAST
30696 YMIN=MAX(Y1(1),EPS)
30698 YMAX =MAX(Y1(I),YMAX)
30699 IF(Y1(I).GT.EPS) THEN
30700 IF(YMIN.EQ.EPS) THEN
30703 YMIN = MIN(Y1(I),YMIN)
30709 YMAX=MAX(Y2(I),YMAX)
30710 IF(Y2(I).GT.EPS) THEN
30711 IF(YMIN.EQ.EPS) THEN
30714 YMIN = MIN(Y2(I),YMIN)
30721 Y1(I) = MAX(Y1(I),YMIN)
30725 Y2(I) = MAX(Y2(I),YMIN)
30729 IF(YMAX.LE.YMIN) THEN
30730 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30731 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30732 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30736 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30737 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30738 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30739 IF(YZOOM.LT.EPS) THEN
30740 WRITE(LOUT,'(1X,A)')
30741 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30750 L=NINT((X(K)-XMIN)/XZOOM)
30751 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30752 IF(ILAST.GE.0) THEN
30755 DO 55 II=0,LD,SIGN(1,LD)
30756 DO 66 KK=0,ID,SIGN(1,ID)
30757 COL(II+LLAST,KK+ILAST)=SYMB(1)
30772 L=NINT((X(K)-XMIN)/XZOOM)
30773 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30780 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30781 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30783 C*** write range of X
30785 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30786 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30788 DO 1300 K=0,IZEIL-1
30789 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30790 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30791 110 FORMAT(1X,1PE9.2,70A1)
30794 C*** write range of X
30796 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30797 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30798 120 FORMAT(6X,7(1PE10.3))
30802 *$ CREATE DT_SRPLOT.FOR
30805 *===plot===============================================================*
30807 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30809 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30812 PARAMETER ( LINP = 10 ,
30817 * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30818 * This is a subroutine of fluka to plot Y across the page
30819 * as a function of X down the page. Up to 37 curves can be
30820 * plotted in the same picture with different plotting characters.
30821 * Output of first 10 overprinted characters addad by FB 88
30822 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30825 * X = array containing the values of X
30826 * Y = array containing the values of Y
30827 * N = number of values in X and in Y
30828 * can exceed the fixed number of lines
30829 * M = number of different curves X,Y are containing
30830 * MM = number of points in each curve i.e. N=M*MM
30831 * XO = smallest value of X to be plotted
30832 * DX = increment of X between subsequent lines
30833 * YO = smallest value of Y to be plotted
30834 * DY = increment of Y between subsequent character spaces
30836 * other variables used inside:
30837 * XX = numbers along the X-coordinate axis
30838 * YY = numbers along the Y-coordinate axis
30839 * LL = ten lines temporary storage for the plot
30840 * L = character set used to plot different curves
30841 * LOV = memorizes overprinted symbols
30842 * the first 10 overprinted symbols are printed on
30843 * the end of the line to avoid ambiguities
30844 * (added by FB as considered quite helpful)
30846 *********************************************************************
30848 DIMENSION XX(61),YY(61),LL(101,10)
30849 DIMENSION X(N),Y(N),L(40),LOV(40,10)
30850 INTEGER*4 LL, L, LOV
30852 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30853 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30854 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30855 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30864 20 YY(I)=YO+10.0D0*AI*DY
30865 WRITE(LOUT, 500) (YY(I),I=1,11)
30887 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30888 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30890 * changed Sept.88 by FB to avoid INTEGER OVERFLOW
30891 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30892 + . AIY .LT. 102.D0) THEN
30895 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30897 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30908 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30909 & (LOV(J,I),J=1,10)
30915 WRITE(LOUT, 500) (YY(I),I=1,11)
30918 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30919 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30920 520 FORMAT(20X,10('1---------'),'1')
30923 *$ CREATE DT_DEFSET.FOR
30926 *===defset=============================================================*
30928 BLOCK DATA DT_DEFSET
30930 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30933 * flags for input different options
30934 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30935 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30936 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30937 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30938 * emulsion treatment
30939 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30943 DATA IFRAG / 2, 1 /
30947 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30948 DATA LEMCCK / .FALSE. /
30949 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30950 & .TRUE.,.TRUE.,.TRUE./
30951 DATA LSEADI / .TRUE. /
30952 DATA LEVAPO / .TRUE. /
30957 DATA EMUFRA / NCOMPX*0.0D0 /
30958 DATA IEMUMA / NCOMPX*1 /
30959 DATA IEMUCH / NCOMPX*1 /
30965 *$ CREATE DT_HADPRP.FOR
30968 *===hadprp=============================================================*
30970 BLOCK DATA DT_HADPRP
30972 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30975 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30976 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30977 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30978 & IQTCHR(-6:6),MQUARK(3,39)
30979 * hadron index conversion (BAMJET <--> PDG)
30980 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30981 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30983 * names of hadrons used in input-cards
30985 COMMON /DTPAIN/ BTYPE(30)
30988 *----------------------------------------------------------------------*
30990 * Quark content of particles: *
30991 * index quark el. charge bar. charge isospin isospin3 *
30992 * 1 = u 2/3 1/3 1/2 1/2 *
30993 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
30994 * 2 = d -1/3 1/3 1/2 -1/2 *
30995 * -2 = dbar 1/3 -1/3 1/2 1/2 *
30996 * 3 = s -1/3 1/3 0 0 *
30997 * -3 = sbar 1/3 -1/3 0 0 *
30998 * 4 = c 2/3 1/3 0 0 *
30999 * -4 = cbar -2/3 -1/3 0 0 *
31000 * 5 = b -1/3 1/3 0 0 *
31001 * -5 = bbar 1/3 -1/3 0 0 *
31002 * 6 = t 2/3 1/3 0 0 *
31003 * -6 = tbar -2/3 -1/3 0 0 *
31005 * Mquark = particle quark composition (Paprop numbering) *
31006 * Iqechr = electric charge ( in 1/3 unit ) *
31007 * Iqbchr = baryonic charge ( in 1/3 unit ) *
31008 * Iqichr = isospin ( in 1/2 unit ), z component *
31009 * Iqschr = strangeness *
31011 * Iquchr = beauty *
31012 * Iqtchr = ...... *
31014 *----------------------------------------------------------------------*
31015 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
31016 DATA IQBCHR / 6*-1, 0, 6*1 /
31017 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
31018 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
31019 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
31020 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
31021 DATA IQTCHR / -1, 11*0, 1 /
31023 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31024 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
31025 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
31026 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
31027 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
31028 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31029 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
31030 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
31033 * (renamed) (HAdron InDex COnversion)
31034 * translation table version filled up by r.e. 25.01.94 *
31036 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
31037 &13,130,211,-211,321, -321,3122,-3122,310,3112,
31038 &3222,3212,111,311,-311, 0,0,0,0,0,
31039 &221,213,113,-213,223, 323,313,-323,-313,10323,
31040 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
31041 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
31042 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
31043 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31045 &4*99999,331, 333,3322,3312,-3222,-3212,
31046 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
31047 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
31048 &-431,441,423,413,-413, -423,433,-433,20443,443,
31049 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
31050 &4212,4112,3*99999, 3*99999,-4122,-4232,
31051 &-4132,-4222,-4212,-4112,99999, 5*99999,
31054 &5*99999 , 20211,20111,-20211,99999,20321,
31055 &-20321,20311,-20311,7*99999 ,
31056 &7*99999,12212,12112,99999/
31059 * (HAdron InDex COnversion)
31060 DATA (IPDG2(1,K),K=1,7)
31061 & / -11, -12, -13, -15, -16, -14, 0/
31062 DATA (IBAM2(1,K),K=1,7)
31063 & / 4, 6, 10, 131, 134, 136, 0/
31064 DATA (IPDG2(2,K),K=1,7)
31065 & / 11, 12, 22, 13, 15, 16, 14/
31066 DATA (IBAM2(2,K),K=1,7)
31067 & / 3, 5, 7, 11, 132, 133, 135/
31068 DATA (IPDG3(1,K),K=1,22)
31069 & / -211, -321, -311, -213, -323, -313, -411, -421,
31070 & -431, -413, -423, -433, 0, 0, 0, 0,
31071 & 0, 0, 0, 0, 0, 0/
31072 DATA (IBAM3(1,K),K=1,22)
31073 & / 14, 16, 25, 34, 38, 39, 118, 119,
31074 & 121, 125, 126, 128, 0, 0, 0, 0,
31075 & 0, 0, 0, 0, 0, 0/
31076 DATA (IPDG3(2,K),K=1,22)
31077 & / 130, 211, 321, 310, 111, 311, 221, 213,
31078 & 113, 223, 323, 313, 331, 333, 421, 411,
31079 & 431, 441, 423, 413, 433, 443/
31080 DATA (IBAM3(2,K),K=1,22)
31081 & / 12, 13, 15, 19, 23, 24, 31, 32,
31082 & 33, 35, 36, 37, 95, 96, 116, 117,
31083 & 120, 122, 123, 124, 127, 130/
31084 DATA (IPDG4(1,K),K=1,29)
31085 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31086 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31087 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31088 & -4212, -4112, 0, 0, 0/
31089 DATA (IBAM4(1,K),K=1,29)
31090 & / 2, 9, 18, 67, 68, 69, 70, 75,
31091 & 76, 99, 100, 101, 102, 103, 110, 111,
31092 & 112, 113, 114, 115, 149, 150, 151, 152,
31093 & 153, 154, 0, 0, 0/
31094 DATA (IPDG4(2,K),K=1,29)
31095 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31096 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31097 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31098 & 4232, 4132, 4222, 4212, 4112/
31099 DATA (IBAM4(2,K),K=1,29)
31100 & / 1, 8, 17, 20, 21, 22, 48, 49,
31101 & 50, 51, 52, 53, 54, 55, 56, 97,
31102 & 98, 104, 105, 106, 107, 108, 109, 137,
31103 & 138, 139, 140, 141, 142/
31104 DATA (IPDG5(1,K),K=1,19)
31105 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31106 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31108 DATA (IBAM5(1,K),K=1,19)
31109 & / 42, 43, 46, 47, 71, 72, 73, 74,
31110 & 188, 191, 193, 0, 0, 0, 0, 0,
31112 DATA (IPDG5(2,K),K=1,19)
31113 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31114 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31115 & 20311, 12212, 12112/
31116 DATA (IBAM5(2,K),K=1,19)
31117 & / 40, 41, 44, 45, 57, 58, 59, 60,
31118 & 63, 64, 65, 66, 129, 186, 187, 190,
31122 * internal particle names
31123 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31124 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31125 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31126 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31127 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31128 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31133 *$ CREATE DT_BLKD46.FOR
31136 *===blkd46=============================================================*
31138 BLOCK DATA DT_BLKD46
31140 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31143 PARAMETER ( AMELCT = 0.51099906 D-03 )
31144 PARAMETER ( AMMUON = 0.105658389 D+00 )
31146 * particle properties (BAMJET index convention)
31148 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31149 & IICH(210),IIBAR(210),K1(210),K2(210)
31152 * Particle masses Engel version JETSET compatible
31153 C DATA (AAM(K),K=1,85) /
31154 C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31155 C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31156 C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31157 C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31158 C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31159 C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31160 C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31161 C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31162 C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31163 C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31164 C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31165 C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31166 C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31167 C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31168 C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31169 C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31170 C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31171 C DATA (AAM(K),K=86,183) /
31172 C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31173 C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31174 C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31175 C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31176 C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31177 C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31178 C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31179 C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31180 C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31181 C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31182 C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31183 C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31184 C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31185 C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31186 C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31187 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31188 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31189 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31190 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31191 C & .1250D+01, .1250D+01, .1250D+01 /
31192 C DATA (AAM ( I ), I = 184,210 ) /
31193 C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31194 C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31195 C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31196 C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31197 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31198 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31199 C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31200 C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31201 C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31202 * sr 25.1.06: particle masses adjusted to Pythia
31203 DATA (AAM(K),K=1,85) /
31204 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31205 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31206 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31207 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31208 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31209 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31210 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31211 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31212 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31213 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31214 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31215 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31216 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31217 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31218 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31219 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31220 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31221 DATA (AAM(K),K=86,183) /
31222 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31223 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31224 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31225 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31226 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31227 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31228 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31229 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31230 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31231 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31232 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31233 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31234 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31235 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31236 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31237 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31238 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31239 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31240 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31241 & .1250D+01, .1250D+01, .1250D+01 /
31242 DATA (AAM ( I ), I = 184,210 ) /
31243 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31244 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31245 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31246 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31247 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31248 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31249 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31250 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31251 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31252 * Particle mean lives
31253 DATA (TAU(K),K=1,183) /
31254 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31255 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31256 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31257 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31258 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31260 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31261 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31262 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31263 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31264 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31265 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31266 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31267 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31268 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31270 & .0000D+00, .0000D+00, .0000D+00 /
31271 DATA ( TAU ( I ), I = 184,210 ) /
31272 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31273 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31274 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31275 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31276 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31277 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31278 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31279 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31280 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31281 * Resonance width Gamma in GeV
31282 DATA (GA(K),K= 1,85) /
31284 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31285 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31286 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31287 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31288 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31289 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31290 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31291 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31292 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31293 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31294 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31295 DATA (GA(K),K= 86,183) /
31296 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31297 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31298 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31299 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31300 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31301 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31302 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31303 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31304 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31306 & .3000D+00, .3000D+00, .3000D+00 /
31307 DATA ( GA ( I ), I = 184,210 ) /
31308 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31309 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31310 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31311 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31312 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31313 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31314 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31315 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31316 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31318 * S+1385+Sigma+(1385) L02030+Lambda0(2030)
31319 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31320 * designation N*@@ means N*@1(@2)
31321 DATA (ANAME(K),K=1,85) /
31322 & 'P ','AP ','E- ','E+ ','NUE ',
31323 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31324 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31325 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31326 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31327 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31328 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31329 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31330 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31331 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31332 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31333 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31334 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31335 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31336 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31337 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31338 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31339 DATA (ANAME(K),K=86,183) /
31340 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31341 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31342 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31343 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31344 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31345 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31346 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31347 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31348 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31349 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31350 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31351 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31352 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31353 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31354 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31355 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31356 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31357 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31358 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31359 & 'RO ','R+ ','R- ' /
31360 DATA ( ANAME ( I ), I = 184,210 ) /
31361 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31362 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31363 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31364 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31365 &'N*+14 ','N*014 ','BLANK '/
31366 * Charge of particles and resonances
31367 DATA (IICH ( I ), I = 1,210 ) /
31368 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31369 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31370 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31371 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31372 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31373 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31374 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31375 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31376 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31377 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31378 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31379 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31380 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31381 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31382 * Particle baryonic charges
31383 DATA (IIBAR ( I ), I = 1,210 ) /
31384 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31385 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31386 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31387 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31388 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31389 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31390 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31391 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31392 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31393 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31394 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31395 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31396 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31397 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31398 * First number of decay channels used for resonances
31399 * and decaying particles
31400 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31401 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31402 & 2*330, 46, 51, 52, 54, 55, 58,
31404 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31405 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31406 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31408 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31409 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31410 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31411 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31412 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31413 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31414 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31415 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31416 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31417 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31419 * Last number of decay channels used for resonances
31420 * and decaying particles
31421 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31422 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31423 & 2* 330, 50, 51, 53, 54, 57,
31425 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31426 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31427 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31429 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31430 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31431 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31432 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31433 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31434 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31435 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31436 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31437 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31438 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31439 & 589, 595, 601, 602 /
31443 *$ CREATE DT_BLKD47.FOR
31446 *===blkd47=============================================================*
31448 BLOCK DATA DT_BLKD47
31450 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31453 * HADRIN: decay channel information
31454 PARAMETER (IDMAX9=602)
31456 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31458 * Name of decay channel
31459 * Designation N*@ means N*@1(1236)
31460 * @1=# means ++, @1 = = means --
31461 * Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31462 DATA (ZKNAME(K),K= 1, 85) /
31463 & 'P ','AP ','E- ','E+ ','NUE ',
31464 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31465 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31466 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31467 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31468 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31469 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31470 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31471 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31472 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31473 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31474 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31475 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31476 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31477 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31478 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31479 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31480 DATA (ZKNAME(K),K= 86,170) /
31481 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31482 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31483 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31484 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31485 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31486 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31487 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31488 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31489 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31490 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31491 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31492 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31493 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31494 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31495 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31496 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31497 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31498 DATA (ZKNAME(K),K=171,255) /
31499 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31500 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31501 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31502 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31503 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31504 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31505 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31506 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31507 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31508 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31509 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31510 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31511 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31512 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31513 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31514 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31515 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31516 DATA (ZKNAME(K),K=256,340) /
31517 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31518 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31519 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31520 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31521 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31522 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31523 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31524 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31525 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31526 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31527 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31528 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31529 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31530 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31531 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31532 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31533 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31534 DATA (ZKNAME(K),K=341,425) /
31535 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31536 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31537 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31538 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31539 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31540 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31541 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31542 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31543 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31544 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31545 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31546 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31547 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31548 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31549 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31550 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31551 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31552 DATA (ZKNAME(K),K=426,510) /
31553 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31554 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31555 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31556 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31557 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31558 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31559 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31560 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31561 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31562 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31563 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31564 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31565 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31566 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31567 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31568 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31569 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31570 DATA (ZKNAME(K),K=511,540) /
31571 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31572 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31573 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31574 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31575 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31576 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31577 DATA (ZKNAME(I),I=541,602)/
31578 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31579 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31580 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31581 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31582 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31583 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31584 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31585 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31586 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31587 * Weight of decay channel
31588 DATA (WT(K),K= 1, 85) /
31589 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31590 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31591 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31592 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31593 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31594 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31595 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31596 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31597 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31598 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31599 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31600 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31601 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31602 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31603 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31604 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31605 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31606 DATA (WT(K),K= 86,170) /
31607 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31608 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31609 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31610 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31611 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31612 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31613 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31614 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31615 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31616 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31617 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31618 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31619 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31620 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31621 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31622 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31623 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31624 DATA (WT(K),K=171,255) /
31625 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31626 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31627 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31628 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31629 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31630 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31631 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31632 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31633 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31634 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31635 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31636 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31637 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31638 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31639 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31640 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31641 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31642 DATA (WT(K),K=256,340) /
31643 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31644 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31645 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31646 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31647 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31648 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31649 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31650 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31651 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31652 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31653 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31654 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31655 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31656 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31657 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31658 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31659 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31660 DATA (WT(K),K=341,425) /
31661 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31662 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31663 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31664 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31665 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31666 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31667 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31668 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31669 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31670 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31671 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31672 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31673 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31674 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31675 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31676 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31677 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31678 DATA (WT(K),K=426,510) /
31679 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31680 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31681 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31682 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31683 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31684 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31685 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31686 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31687 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31688 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31689 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31690 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31691 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31692 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31693 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31694 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31695 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31696 DATA (WT(K),K=511,540) /
31697 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31698 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31699 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31700 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31701 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31702 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31704 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31705 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31706 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31707 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31708 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31709 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31710 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31711 * Particle numbers in decay channel
31712 DATA (NZK(K,1),K= 1,170) /
31713 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31714 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31715 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31716 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31717 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31718 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31719 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31720 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31721 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31722 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31723 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31724 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31725 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31726 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31727 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31728 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31729 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31730 DATA (NZK(K,1),K=171,340) /
31731 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31732 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31733 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31734 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31735 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31736 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31737 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31738 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31739 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31740 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31741 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31742 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31743 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31744 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31745 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31746 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31747 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31748 DATA (NZK(K,1),K=341,510) /
31749 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31750 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31751 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31752 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31753 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31754 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31755 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31756 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31757 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31758 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31759 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31760 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31761 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31762 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31763 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31764 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31765 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31766 DATA (NZK(K,1),K=511,540) /
31767 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31768 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31769 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31770 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31771 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31772 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31773 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31774 & 55, 8, 1, 8, 8, 54, 55, 210/
31775 DATA (NZK(K,2),K= 1,170) /
31776 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31777 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31778 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31779 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31780 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31781 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31782 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31783 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31784 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31785 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31786 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31787 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31788 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31789 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31790 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31791 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31792 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31793 DATA (NZK(K,2),K=171,340) /
31794 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31795 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31796 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31797 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31798 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31799 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31800 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31801 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31802 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31803 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31804 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31805 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31806 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31807 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31808 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31809 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31810 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31811 DATA (NZK(K,2),K=341,510) /
31812 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31813 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31814 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31815 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31816 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31817 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31818 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31819 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31820 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31821 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31822 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31823 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31824 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31825 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31826 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31827 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31828 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31829 DATA (NZK(K,2),K=511,540) /
31830 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31831 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31832 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31833 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31834 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31835 & 14, 14, 23, 14, 16, 25,
31836 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31837 & 23, 13, 14, 23, 0 /
31838 DATA (NZK(K,3),K= 1,170) /
31839 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31840 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31841 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31842 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31843 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31844 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31846 DATA (NZK(K,3),K=171,340) /
31848 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31849 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31850 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31851 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31852 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31854 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31855 DATA (NZK(K,3),K=341,510) /
31857 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31858 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31859 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31860 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31861 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31862 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31864 DATA (NZK(K,3),K=511,540) /
31865 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31866 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31867 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31868 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31869 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31873 *$ CREATE DT_BDEVAP.FOR
31876 *=== bdevap ===========================================================*
31878 BLOCK DATA DT_BDEVAP
31880 C INCLUDE '(DBLPRC)'
31882 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31884 * (original name: GLOBAL)
31885 PARAMETER ( KALGNM = 2 )
31886 PARAMETER ( ANGLGB = 5.0D-16 )
31887 PARAMETER ( ANGLSQ = 2.5D-31 )
31888 PARAMETER ( AXCSSV = 0.2D+16 )
31889 PARAMETER ( ANDRFL = 1.0D-38 )
31890 PARAMETER ( AVRFLW = 1.0D+38 )
31891 PARAMETER ( AINFNT = 1.0D+30 )
31892 PARAMETER ( AZRZRZ = 1.0D-30 )
31893 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31894 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31895 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31896 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31897 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
31898 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
31899 PARAMETER ( CSNNRM = 2.0D-15 )
31900 PARAMETER ( DMXTRN = 1.0D+08 )
31901 PARAMETER ( ZERZER = 0.D+00 )
31902 PARAMETER ( ONEONE = 1.D+00 )
31903 PARAMETER ( TWOTWO = 2.D+00 )
31904 PARAMETER ( THRTHR = 3.D+00 )
31905 PARAMETER ( FOUFOU = 4.D+00 )
31906 PARAMETER ( FIVFIV = 5.D+00 )
31907 PARAMETER ( SIXSIX = 6.D+00 )
31908 PARAMETER ( SEVSEV = 7.D+00 )
31909 PARAMETER ( EIGEIG = 8.D+00 )
31910 PARAMETER ( ANINEN = 9.D+00 )
31911 PARAMETER ( TENTEN = 10.D+00 )
31912 PARAMETER ( HLFHLF = 0.5D+00 )
31913 PARAMETER ( ONETHI = ONEONE / THRTHR )
31914 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31915 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31916 PARAMETER ( THRTWO = THRTHR / TWOTWO )
31917 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31918 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31919 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31920 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31921 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31922 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31923 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31924 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
31925 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
31926 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
31927 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
31928 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31929 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31930 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31931 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31932 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31933 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31934 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31935 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31936 PARAMETER ( CLIGHT = 2.99792458 D+10 )
31937 PARAMETER ( AVOGAD = 6.0221367 D+23 )
31938 PARAMETER ( BOLTZM = 1.380658 D-23 )
31939 PARAMETER ( AMELGR = 9.1093897 D-28 )
31940 PARAMETER ( PLCKBR = 1.05457266 D-27 )
31941 PARAMETER ( ELCCGS = 4.8032068 D-10 )
31942 PARAMETER ( ELCMKS = 1.60217733 D-19 )
31943 PARAMETER ( AMUGRM = 1.6605402 D-24 )
31944 PARAMETER ( AMMUMU = 0.113428913 D+00 )
31945 PARAMETER ( AMPRMU = 1.007276470 D+00 )
31946 PARAMETER ( AMNEMU = 1.008664904 D+00 )
31947 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31948 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31949 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31950 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31951 PARAMETER ( PLABRC = 0.197327053 D+00 )
31952 PARAMETER ( AMELCT = 0.51099906 D-03 )
31953 PARAMETER ( AMUGEV = 0.93149432 D+00 )
31954 PARAMETER ( AMMUON = 0.105658389 D+00 )
31955 PARAMETER ( AMPRTN = 0.93827231 D+00 )
31956 PARAMETER ( AMNTRN = 0.93956563 D+00 )
31957 PARAMETER ( AMDEUT = 1.87561339 D+00 )
31958 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31960 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31961 PARAMETER ( BLTZMN = 8.617385 D-14 )
31962 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31963 PARAMETER ( GFOHB3 = 1.16639 D-05 )
31964 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31965 PARAMETER ( SIN2TW = 0.2319 D+00 )
31966 PARAMETER ( GEVMEV = 1.0 D+03 )
31967 PARAMETER ( EMVGEV = 1.0 D-03 )
31968 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
31969 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31970 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31971 LOGICAL LGBIAS, LGBANA
31972 COMMON /FKGLOB/ LGBIAS, LGBANA
31973 C INCLUDE '(DIMPAR)'
31975 PARAMETER ( MXXRGN = 5000 )
31976 PARAMETER ( MXXMDF = 82 )
31977 PARAMETER ( MXXMDE = 54 )
31978 PARAMETER ( MFSTCK = 1000 )
31979 PARAMETER ( MESTCK = 100 )
31980 PARAMETER ( NELEMX = 80 )
31981 PARAMETER ( MPDPDX = 8 )
31982 PARAMETER ( ICOMAX = 180 )
31983 PARAMETER ( NSTBIS = 304 )
31984 PARAMETER ( IDMAXP = 220 )
31985 PARAMETER ( IDMXDC = 640 )
31986 PARAMETER ( MKBMX1 = 1 )
31987 PARAMETER ( MKBMX2 = 1 )
31988 C INCLUDE '(IOUNIT)'
31990 PARAMETER ( LUNIN = 5 )
31991 PARAMETER ( LUNOUT = 6 )
31992 **sr 19.5. set error output-unit from 15 to 6
31993 PARAMETER ( LUNERR = 6 )
31994 PARAMETER ( LUNBER = 14 )
31995 PARAMETER ( LUNECH = 8 )
31996 PARAMETER ( LUNFLU = 13 )
31997 PARAMETER ( LUNGEO = 16 )
31998 PARAMETER ( LUNPMF = 12 )
31999 PARAMETER ( LUNRAN = 2 )
32000 PARAMETER ( LUNXSC = 9 )
32001 PARAMETER ( LUNDET = 17 )
32002 PARAMETER ( LUNRAY = 10 )
32003 PARAMETER ( LUNRDB = 1 )
32004 PARAMETER ( LUNPGO = 7 )
32005 PARAMETER ( LUNPGS = 4 )
32006 PARAMETER ( LUNSCR = 3 )
32008 *----------------------------------------------------------------------*
32010 * Block Data for the EVAPoration routines: *
32012 * Created on 20 may 1990 by Alfredo Ferrari & Paola Sala *
32015 * Modified from the original version of J.M.Zazula *
32016 * and, for cookcm, from a LAHET block data kindly provided by *
32019 * Last change on 20-feb-95 by Alfredo Ferrari *
32022 *----------------------------------------------------------------------*
32024 * (original name: COOKCM)
32025 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
32026 LOGICAL LDEFOZ, LDEFON
32027 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
32028 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
32029 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
32030 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
32031 * (original name: EVA0)
32032 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
32033 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
32034 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32035 * T (4,7), RMASS (297), ALPH (297), BET (297),
32036 * APRIME (250), IA (6), IZ (6)
32037 * (original name: HETTP)
32038 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
32039 * (original name: HETC7)
32040 COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32041 * (original name: INPFLG)
32042 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32044 DATA B0 / 8.D+00 /, Y0 / 1.5D+00 /
32045 DATA IANG / 1 /, IFISS / 1 /, IB0 / 2 /, IGEOM / 0 /
32046 DATA ISTRAG /0/, KEYDK /0/
32047 DATA NBERTP /LUNBER/
32048 DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32051 DATA ( PZCOOK(I),I = 1, IZCOOK ) /
32052 & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32053 & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32054 & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32055 & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32056 & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32057 & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32058 & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32059 & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32060 & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32061 & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32062 &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32063 & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32064 & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32065 & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32066 & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32067 &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32068 & 0.000D+00, 7.700D-01/
32069 DATA ( PNCOOK(I),I = 1, 90 ) /
32070 & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32071 & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32072 & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32073 & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32074 & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32075 & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32076 &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32077 & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32078 & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32079 & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32080 &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32081 &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32082 &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32083 &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32084 &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32085 DATA ( PNCOOK(I),I = 91, INCOOK ) /
32086 &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32087 &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32088 & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32089 & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32090 &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32091 & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32092 & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32093 & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32094 & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32095 & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32096 DATA ( SZCOOK(I),I = 1, 98) /
32097 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32098 & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32099 &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32100 &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32101 &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32102 &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32103 &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32104 &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32105 &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32106 &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32107 &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32108 &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32109 &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32110 &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32111 &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32112 &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32113 &-7.200D+00,-7.740D+00/
32114 DATA ( SNCOOK(I),I = 1, 90 ) /
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.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32117 & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32118 & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32119 & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32120 & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32121 & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32122 & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32123 & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32124 & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32125 & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32126 & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32127 & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32128 & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32129 & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32130 DATA ( SNCOOK(I),I = 91, INCOOK ) /
32131 & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32132 & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32133 & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32134 & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32135 & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32136 & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32137 &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32138 & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32139 & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32140 & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32141 DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32142 DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32143 *=== End of Block Data Bdevap =========================================*
32146 *$ CREATE DT_BDNOPT.FOR
32149 *=== bdnopt ===========================================================*
32151 BLOCK DATA DT_BDNOPT
32153 C INCLUDE '(DBLPRC)'
32155 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32157 * (original name: GLOBAL)
32158 PARAMETER ( KALGNM = 2 )
32159 PARAMETER ( ANGLGB = 5.0D-16 )
32160 PARAMETER ( ANGLSQ = 2.5D-31 )
32161 PARAMETER ( AXCSSV = 0.2D+16 )
32162 PARAMETER ( ANDRFL = 1.0D-38 )
32163 PARAMETER ( AVRFLW = 1.0D+38 )
32164 PARAMETER ( AINFNT = 1.0D+30 )
32165 PARAMETER ( AZRZRZ = 1.0D-30 )
32166 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32167 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32168 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32169 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32170 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32171 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32172 PARAMETER ( CSNNRM = 2.0D-15 )
32173 PARAMETER ( DMXTRN = 1.0D+08 )
32174 PARAMETER ( ZERZER = 0.D+00 )
32175 PARAMETER ( ONEONE = 1.D+00 )
32176 PARAMETER ( TWOTWO = 2.D+00 )
32177 PARAMETER ( THRTHR = 3.D+00 )
32178 PARAMETER ( FOUFOU = 4.D+00 )
32179 PARAMETER ( FIVFIV = 5.D+00 )
32180 PARAMETER ( SIXSIX = 6.D+00 )
32181 PARAMETER ( SEVSEV = 7.D+00 )
32182 PARAMETER ( EIGEIG = 8.D+00 )
32183 PARAMETER ( ANINEN = 9.D+00 )
32184 PARAMETER ( TENTEN = 10.D+00 )
32185 PARAMETER ( HLFHLF = 0.5D+00 )
32186 PARAMETER ( ONETHI = ONEONE / THRTHR )
32187 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32188 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32189 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32190 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32191 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32192 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32193 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32194 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32195 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32196 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32197 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32198 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32199 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32200 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32201 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32202 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32203 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32204 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32205 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32206 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32207 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32208 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32209 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32210 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32211 PARAMETER ( BOLTZM = 1.380658 D-23 )
32212 PARAMETER ( AMELGR = 9.1093897 D-28 )
32213 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32214 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32215 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32216 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32217 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32218 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32219 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32220 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32221 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32222 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32223 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32224 PARAMETER ( PLABRC = 0.197327053 D+00 )
32225 PARAMETER ( AMELCT = 0.51099906 D-03 )
32226 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32227 PARAMETER ( AMMUON = 0.105658389 D+00 )
32228 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32229 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32230 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32231 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32233 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32234 PARAMETER ( BLTZMN = 8.617385 D-14 )
32235 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32236 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32237 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32238 PARAMETER ( SIN2TW = 0.2319 D+00 )
32239 PARAMETER ( GEVMEV = 1.0 D+03 )
32240 PARAMETER ( EMVGEV = 1.0 D-03 )
32241 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32242 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32243 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32244 LOGICAL LGBIAS, LGBANA
32245 COMMON /FKGLOB/ LGBIAS, LGBANA
32246 C INCLUDE '(DIMPAR)'
32248 PARAMETER ( MXXRGN = 5000 )
32249 PARAMETER ( MXXMDF = 82 )
32250 PARAMETER ( MXXMDE = 54 )
32251 PARAMETER ( MFSTCK = 1000 )
32252 PARAMETER ( MESTCK = 100 )
32253 PARAMETER ( NELEMX = 80 )
32254 PARAMETER ( MPDPDX = 8 )
32255 PARAMETER ( ICOMAX = 180 )
32256 PARAMETER ( NSTBIS = 304 )
32257 PARAMETER ( IDMAXP = 220 )
32258 PARAMETER ( IDMXDC = 640 )
32259 PARAMETER ( MKBMX1 = 1 )
32260 PARAMETER ( MKBMX2 = 1 )
32261 C INCLUDE '(IOUNIT)'
32263 PARAMETER ( LUNIN = 5 )
32264 PARAMETER ( LUNOUT = 6 )
32265 **sr 19.5. set error output-unit from 15 to 6
32266 PARAMETER ( LUNERR = 6 )
32267 PARAMETER ( LUNBER = 14 )
32268 PARAMETER ( LUNECH = 8 )
32269 PARAMETER ( LUNFLU = 13 )
32270 PARAMETER ( LUNGEO = 16 )
32271 PARAMETER ( LUNPMF = 12 )
32272 PARAMETER ( LUNRAN = 2 )
32273 PARAMETER ( LUNXSC = 9 )
32274 PARAMETER ( LUNDET = 17 )
32275 PARAMETER ( LUNRAY = 10 )
32276 PARAMETER ( LUNRDB = 1 )
32277 PARAMETER ( LUNPGO = 7 )
32278 PARAMETER ( LUNPGS = 4 )
32279 PARAMETER ( LUNSCR = 3 )
32281 *----------------------------------------------------------------------*
32283 * Created on 20 september 1989 by Alfredo Ferrari - Infn Milan *
32285 * Last change on 20-apr-95 by Alfredo Ferrari *
32287 *----------------------------------------------------------------------*
32289 C INCLUDE '(BLNKCM)'
32291 **sr 17.5. commented since not used here
32292 C PARAMETER ( NBLNMX = 1100000 )
32293 C DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32294 C & BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32295 C & COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32298 C COMMON NSTOR ( KALGNM*NBLNMX )
32300 **sr 18.5. commented since not used for evap.
32301 C COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32302 C & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32303 C & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32304 C & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32305 C & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32306 C & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32307 C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32308 C & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32309 C & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32310 C & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32314 C EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32315 C EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32316 C EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32317 C EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32318 C EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32319 C EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32320 C EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32321 C INCLUDE '(BLNTMP)'
32323 **sr 18.5. commented since not used for evap.
32324 C COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32325 C & KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32326 C & KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32329 C INCLUDE '(CMMDNR)'
32331 **sr 18.5. commented since not used for evap.
32333 C COMMON / CMMDNR / DDNEAR, LFLDNR
32335 C INCLUDE '(CTITLE)'
32337 **sr 18.5. commented since not used for evap.
32338 C CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32339 C COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32340 C COMMON / CEXPCK / ITEXPI, ITEXMX
32342 C INCLUDE '(DETECT)'
32344 **sr 18.5. commented since not used for evap.
32345 C PARAMETER (NRGNMX = 10)
32346 C PARAMETER (NDTCMX = 10)
32347 C PARAMETER (NSCRMX = 10)
32348 C PARAMETER (NDTBIN = 1024)
32349 C CHARACTER*10 TITDET,TITSCO
32351 C COMMON /DETCT/ EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32352 C & KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32353 C & NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32355 C COMMON /DETCH/ TITDET(NDTCMX), TITSCO(NSCRMX)
32357 C INCLUDE '(DETLOC)'
32359 **sr 18.5. commented since not used for evap.
32360 C PARAMETER (NDTCM2 = 10)
32361 C COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32362 C & ICOINC(NDTCM2), NCLAS
32364 C INCLUDE '(EMGTRN)'
32366 **sr 18.5. commented since not used for evap.
32368 C COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32370 C INCLUDE '(EMSHO)'
32372 **sr 18.5. commented since not used for evap.
32373 C LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32374 C COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32375 C & EMFHLO, EMFELO, LIMPRE, LEXPTE
32377 C INCLUDE '(EPISOR)'
32379 **sr 18.5. commented since not used for evap.
32381 C COMMON/EPISOR/TKESUM,LUSSRC
32383 * (original name: FHEAVY,FHEAVC)
32384 PARAMETER ( MXHEAV = 100 )
32386 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32387 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32388 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32389 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
32390 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
32391 & IBHEAV ( 12 ) , NPHEAV
32392 COMMON /FKFHVC/ ANHEAV ( 12 )
32393 * (original name: FINUC)
32394 PARAMETER (MXP=999)
32395 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
32396 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32397 & TKI (MXP), PLR (MXP), WEI (MXP),
32398 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32400 C INCLUDE '(GENTHR)'
32402 **sr 18.5. commented since not used for evap.
32403 C COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32404 C & PTHDFF (NALLWP), IJNUCR (NALLWP)
32406 C INCLUDE '(LOWNEU)'
32408 **sr 18.5. commented since not used for evap.
32409 C PARAMETER ( MXGTHN = 15 )
32410 C PARAMETER ( MXGLWN = 200 )
32411 C PARAMETER ( MXSHPP = 5 )
32412 C LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32413 C CHARACTER*10 TITLOW
32414 C COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32415 C & SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32416 C & VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32417 C & STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32418 C & TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32419 C & IGTMRT (MXXMDF), NEUMED (MXXMDF),
32420 C & ID1MED (MXXMDF), ID2MED (MXXMDF),
32421 C & ID3MED (MXXMDF), MGTMED (MXXMDF),
32422 C & LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32423 C & NMTG , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32424 C & LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32425 C & I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32426 C & IWWLWT, IPXBGN, NPXSEC
32427 C COMMON / CHLWNT / TITLOW (MXXMDF)
32429 C INCLUDE '(LTCLCM)'
32431 **sr 18.5. commented since not used for evap.
32432 C COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32434 C INCLUDE '(MULBOU)'
32436 **sr 18.5. commented since not used for evap.
32437 C LOGICAL LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32438 C COMMON / MULBOU / UOLD , VOLD , WOLD , UMAG , VMAG , WMAG ,
32439 C & UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32440 C & TSENSE, DDSENS, DSMALL, NSSENS, LLDA , LAGAIN,
32441 C & LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32443 C INCLUDE '(MULHD)'
32445 **sr 18.5. commented since not used for evap.
32446 C PARAMETER ( MXXPT1 = 1 )
32447 C PARAMETER ( TIMESS = 2.00D+00 )
32448 C PARAMETER ( TMSRLX = 1.50D+00 )
32449 C PARAMETER ( EPSINS = 0.15D+00 )
32450 C PARAMETER ( EPSRLX = 0.50D+00 )
32451 C PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32452 C PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32453 C PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32454 C PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32455 C PARAMETER ( R0NCMS = 1.20 D+00 )
32456 C LOGICAL LTOPT, LSRCRH, LNSCRH
32457 C COMMON / MULHD / BLCC ( MXXMDF ), BLCCRA ( MXXMDF ),
32458 C & XCC ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32459 C & ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU ( MXXMDF ),
32460 C & ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0 ( MXXMDF ),
32461 C & XR0 ( MXXMDF ), ECUTM ( MXXMDF, 39, 2 ),
32462 C & ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32463 C & AE1O3 ( MXXMDF ), PARNSR ( MXXMDF ),
32464 C & HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32465 C & HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32466 C & LTOPT ( MXXMDF ), NFSCAT
32468 * (original name: PAREVT)
32469 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32470 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32471 PARAMETER ( NALLWP = 39 )
32472 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32473 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32474 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32475 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32476 * (original name: RESNUC)
32477 LOGICAL LRNFSS, LFRAGM
32478 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32479 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32480 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
32481 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
32482 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32483 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32484 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32485 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32487 C INCLUDE '(SCOHLP)'
32489 **sr 18.5. commented since not used for evap.
32491 C COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32493 C INCLUDE '(TRACKR)'
32495 **sr 18.5. commented since not used for evap.
32496 C PARAMETER ( MXTRCK = 2500 )
32498 C COMMON / TRACKR / XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32499 C & ZTRACK ( 0:MXTRCK ), TTRACK ( MXTRCK ),
32500 C & DTRACK ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32501 C & ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32502 C & NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32503 C & LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32505 C INCLUDE '(USRBDX)'
32507 **sr 18.5. commented since not used for evap.
32508 C PARAMETER ( MXUSBX = 600 )
32509 C LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32510 C CHARACTER*10 TITUSX
32511 C COMMON /USRBX/ EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32512 C & ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32513 C & AUSBDX(MXUSBX),
32514 C & NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32515 C & NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32516 C & KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32517 C & LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32519 C COMMON /USXCH/ TITUSX(MXUSBX)
32521 C INCLUDE '(USRBIN)'
32523 **sr 18.5. commented since not used for evap.
32524 C PARAMETER ( MXUSBN = 100 )
32525 C LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32526 C CHARACTER*10 TITUSB
32527 C COMMON /USRBN/ XLOW (MXUSBN), XHIGH (MXUSBN), YLOW (MXUSBN),
32528 C & YHIGH (MXUSBN), ZLOW (MXUSBN), ZHIGH (MXUSBN),
32529 C & DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32530 C & TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32531 C & NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32532 C & ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32533 C & IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32534 C & LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32535 C COMMON /USRCH/ TITUSB(MXUSBN)
32537 C INCLUDE '(USRSNC)'
32539 **sr 18.5. commented since not used for evap.
32540 C PARAMETER ( MXRSNC = 400 )
32541 C PARAMETER ( NMZMIN = -5 )
32543 C CHARACTER*10 TIURSN
32544 C COMMON /USRSNC/ VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32545 C & NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32546 C & IPURSN(MXRSNC), NURSNC, LURSNC
32547 C COMMON /USRSCH/ TIURSN(MXRSNC)
32548 C INCLUDE '(USRTRC)'
32550 **sr 18.5. commented since not used for evap.
32551 C PARAMETER ( MXUSTC = 400 )
32552 C LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32553 C CHARACTER*10 TITUTC
32554 C COMMON /USRTC/ ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32555 C & VUSRTC(MXUSTC),
32556 C & IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32557 C & NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32558 C & KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32559 C & LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32561 C COMMON /USTCH/ TITUTC(MXUSTC)
32563 C INCLUDE '(USRYLD)'
32565 **sr 18.5. commented since not used for evap.
32566 C PARAMETER ( MXUSYL = 500 )
32567 C LOGICAL LUSRYL, LLNUYL, LSCUYL
32568 C CHARACTER*10 TITUYL
32569 C COMMON /USRYL/ EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32570 C & USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32571 C & AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32572 C & ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32573 C & VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32574 C & NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32575 C & IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32576 C & KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32577 C & IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32578 C & NUSRYL, LUSRYL, LSCUYL
32579 C COMMON /USYCH/ TITUYL(MXUSYL)
32581 C INCLUDE '(WWINDW)'
32583 **sr 18.5. commented since not used for evap.
32584 C PARAMETER ( MXWWSP = 3 )
32585 C PARAMETER ( WWSPMX = 50.D+00 )
32586 C LOGICAL LWWNDW, LWWPRM
32587 C COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32588 C & WWEXWD (NALLWP), EXTWWN (NALLWP),
32589 C & IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32593 * *** If blank common dimension has to be superseded substitute in the
32594 * *** following two lines the new dimension in real*8 units to Nblnmx
32595 **sr 18.5. commented since not used for evap.
32596 C PARAMETER (MXDUMM = KALGNM * NBLNMX)
32597 C DATA KTMBGN / NBLNMX /
32598 C DATA MBLNMX / MXDUMM /
32599 C DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32600 C & KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32601 C & KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32602 C & KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32603 C & KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32604 C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32605 C & KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32606 C & KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32607 C & KBRLST / 57*0 /
32610 **sr 18.5. commented since not used for evap.
32611 C DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32612 C & KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32613 C & KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32616 **sr 18.5. commented since not used for evap.
32617 C DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32620 **sr 18.5. commented since not used for evap.
32621 C DATA RUNTIT (1:40) / '****************************************' /
32622 C DATA RUNTIT(41:80) / '****************************************' /
32623 C DATA ITEXPI, ITEXMX / 100000000, 150 /
32625 **sr 18.5. commented since not used for evap.
32626 C PARAMETER (NNN1 = NRGNMX*NDTCMX)
32627 C PARAMETER (NNN2 = NSCRMX*NDTCMX)
32628 C DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32629 C DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32630 C DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32631 C DATA TITDET/NDTCMX*' '/, TITSCO/NSCRMX*' '/
32634 **sr 18.5. commented since not used for evap.
32635 C DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32639 **sr 18.5. commented since not used for evap.
32640 C DATA LMCSMG / .FALSE. /
32643 **sr 18.5. commented since not used for evap.
32644 C DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32647 **sr 18.5. commented since not used for evap.
32648 C DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32651 DATA AMHEAV / 12 * 0.D+00 /
32652 DATA ANHEAV / 'NEUTRON ', 'PROTON ', 'DEUTERON', '3-H ',
32653 & '3-He ', '4-He ', 'H-FRAG-1', 'H-FRAG-2',
32654 & 'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32655 DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32656 & IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32660 DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32661 & TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32665 * DATA PEANCT, PEAPIT / 2*1.D+00 /
32666 * DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32668 * DATA PTHDFF / 39*5.D+00 /
32671 **sr 18.5. commented since not used for evap.
32672 C DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32673 C DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32674 C & 3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32676 C DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32677 C & 3.5D+00, 13*5.D+00 /
32678 C DATA PLDNCT / 0.26D+00 /
32679 C DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32682 **sr 18.5. commented since not used for evap.
32683 C DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32684 C DATA IWWLWB, IWWLWT / 2 * 100000000 /
32685 C DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32686 C DATA IGRTHN / 1 /
32687 C DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32688 C & LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32691 **sr 18.5. commented since not used for evap.
32692 C DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32695 **sr 18.5. commented since not used for evap.
32696 C DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32697 C & / 7 * .FALSE. /
32698 C DATA TSENSE / AINFNT /, NSSENS / -1 /
32699 C DATA DSMALL / ANGLGB /
32702 **sr 18.5. commented since not used for evap.
32703 C DATA LTOPT / MXXMDF * .FALSE. /, NFSCAT / 0 /
32704 C DATA ESTEPF / MXXMDF * 0.1D+00 /
32705 C DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32706 C DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32709 DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32710 & RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32711 DATA LDIFFR / .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32712 & .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32713 & 4 * .FALSE., 9 * .TRUE./
32715 * default value for LEVPRT changed (reset sr 25.7.97)
32716 * default value for LHEAVY changed 25.7.97
32717 C DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32718 C & LHEAVY / .FALSE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32719 C & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32720 C & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32721 DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32722 & LHEAVY / .TRUE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32723 & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32724 & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32727 * default value for ILVMOD changed
32728 C DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32729 DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32733 DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32735 DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32736 & IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32738 DATA LRNFSS / .FALSE. /
32741 **sr 18.5. commented since not used for evap.
32742 C DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32745 **sr 18.5. commented since not used for evap.
32746 C DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32747 C & CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32750 **sr 18.5. commented since not used for evap.
32751 C DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32754 **sr 18.5. commented since not used for evap.
32755 C DATA LUSBDX /.FALSE./, NUSRBX /0/
32758 **sr 18.5. commented since not used for evap.
32759 C DATA LURSNC /.FALSE./, NURSNC /0/
32762 **sr 18.5. commented since not used for evap.
32763 C DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32764 C DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32767 **sr 18.5. commented since not used for evap.
32768 C DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32769 C & IJUSYL /0/, JTUSYL /0/
32770 C DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32773 **sr 18.5. commented since not used for evap.
32774 C DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32775 C DATA LWWPRM / .TRUE. /
32777 *= end*block.bdnopt *
32780 *$ CREATE DT_BDPREE.FOR
32783 *=== bdpree ===========================================================*
32785 BLOCK DATA DT_BDPREE
32787 C INCLUDE '(DBLPRC)'
32789 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32791 * (original name: GLOBAL)
32792 PARAMETER ( KALGNM = 2 )
32793 PARAMETER ( ANGLGB = 5.0D-16 )
32794 PARAMETER ( ANGLSQ = 2.5D-31 )
32795 PARAMETER ( AXCSSV = 0.2D+16 )
32796 PARAMETER ( ANDRFL = 1.0D-38 )
32797 PARAMETER ( AVRFLW = 1.0D+38 )
32798 PARAMETER ( AINFNT = 1.0D+30 )
32799 PARAMETER ( AZRZRZ = 1.0D-30 )
32800 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32801 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32802 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32803 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32804 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32805 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32806 PARAMETER ( CSNNRM = 2.0D-15 )
32807 PARAMETER ( DMXTRN = 1.0D+08 )
32808 PARAMETER ( ZERZER = 0.D+00 )
32809 PARAMETER ( ONEONE = 1.D+00 )
32810 PARAMETER ( TWOTWO = 2.D+00 )
32811 PARAMETER ( THRTHR = 3.D+00 )
32812 PARAMETER ( FOUFOU = 4.D+00 )
32813 PARAMETER ( FIVFIV = 5.D+00 )
32814 PARAMETER ( SIXSIX = 6.D+00 )
32815 PARAMETER ( SEVSEV = 7.D+00 )
32816 PARAMETER ( EIGEIG = 8.D+00 )
32817 PARAMETER ( ANINEN = 9.D+00 )
32818 PARAMETER ( TENTEN = 10.D+00 )
32819 PARAMETER ( HLFHLF = 0.5D+00 )
32820 PARAMETER ( ONETHI = ONEONE / THRTHR )
32821 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32822 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32823 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32824 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32825 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32826 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32827 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32828 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32829 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32830 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32831 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32832 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32833 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32834 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32835 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32836 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32837 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32838 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32839 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32840 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32841 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32842 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32843 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32844 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32845 PARAMETER ( BOLTZM = 1.380658 D-23 )
32846 PARAMETER ( AMELGR = 9.1093897 D-28 )
32847 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32848 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32849 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32850 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32851 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32852 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32853 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32854 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32855 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32856 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32857 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32858 PARAMETER ( PLABRC = 0.197327053 D+00 )
32859 PARAMETER ( AMELCT = 0.51099906 D-03 )
32860 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32861 PARAMETER ( AMMUON = 0.105658389 D+00 )
32862 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32863 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32864 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32865 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32867 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32868 PARAMETER ( BLTZMN = 8.617385 D-14 )
32869 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32870 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32871 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32872 PARAMETER ( SIN2TW = 0.2319 D+00 )
32873 PARAMETER ( GEVMEV = 1.0 D+03 )
32874 PARAMETER ( EMVGEV = 1.0 D-03 )
32875 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32876 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32877 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32878 LOGICAL LGBIAS, LGBANA
32879 COMMON /FKGLOB/ LGBIAS, LGBANA
32880 C INCLUDE '(DIMPAR)'
32882 PARAMETER ( MXXRGN = 5000 )
32883 PARAMETER ( MXXMDF = 82 )
32884 PARAMETER ( MXXMDE = 54 )
32885 PARAMETER ( MFSTCK = 1000 )
32886 PARAMETER ( MESTCK = 100 )
32887 PARAMETER ( NALLWP = 39 )
32888 PARAMETER ( NELEMX = 80 )
32889 PARAMETER ( MPDPDX = 8 )
32890 PARAMETER ( ICOMAX = 180 )
32891 PARAMETER ( NSTBIS = 304 )
32892 PARAMETER ( IDMAXP = 220 )
32893 PARAMETER ( IDMXDC = 640 )
32894 PARAMETER ( MKBMX1 = 1 )
32895 PARAMETER ( MKBMX2 = 1 )
32896 C INCLUDE '(IOUNIT)'
32898 PARAMETER ( LUNIN = 5 )
32899 PARAMETER ( LUNOUT = 6 )
32900 **sr 19.5. set error output-unit from 15 to 6
32901 PARAMETER ( LUNERR = 6 )
32902 PARAMETER ( LUNBER = 14 )
32903 PARAMETER ( LUNECH = 8 )
32904 PARAMETER ( LUNFLU = 13 )
32905 PARAMETER ( LUNGEO = 16 )
32906 PARAMETER ( LUNPMF = 12 )
32907 PARAMETER ( LUNRAN = 2 )
32908 PARAMETER ( LUNXSC = 9 )
32909 PARAMETER ( LUNDET = 17 )
32910 PARAMETER ( LUNRAY = 10 )
32911 PARAMETER ( LUNRDB = 1 )
32912 PARAMETER ( LUNPGO = 7 )
32913 PARAMETER ( LUNPGS = 4 )
32914 PARAMETER ( LUNSCR = 3 )
32916 *----------------------------------------------------------------------*
32918 * Created on 16 september 1991 by Alfredo Ferrari & Paola Sala *
32921 * Last change on 03-feb-94 by Alfredo Ferrari *
32924 *----------------------------------------------------------------------*
32926 * (original name: CMPISG,CHPISG)
32927 PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32928 PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32929 PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32930 PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32931 PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32932 PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32933 PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32934 PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32935 PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32936 PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32937 PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32938 PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32939 PARAMETER ( PIRSMX = 1.2D+00 )
32940 PARAMETER ( NPIREA = 10 )
32941 PARAMETER ( NPIRTA = 68 )
32942 PARAMETER ( NPIRLN = 21 )
32943 PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32944 PARAMETER ( NPISIS = NPIRLN + 20 )
32945 PARAMETER ( NPISEX = NPIRLN + 21 )
32946 PARAMETER ( NPIIMN = 14 )
32947 PARAMETER ( NPIIRC = 6 )
32948 PARAMETER ( DELWLL = 0.035D+00 )
32951 COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32952 & RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32953 & ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32954 & CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32955 & SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32956 & SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5) ,
32957 & SGPICU (0:20,NPIRTA,NPIREA) , SGRTRS (NPIREA),
32958 & SGPIDF (0:20,NPIRTA,NPIREA) , BRREIN (NPIREA),
32959 & SGPIIS (NPIRTA,NPIREA) , BRREOU (NPIREA),
32960 & BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32961 & SGABSR (2,2,4) , PRRSDL,
32962 & IPIREA (2,2,3:5) , IPIINE (2,3:5) , NPIRVR ,
32963 & KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32964 & JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32965 COMMON /FKCHPI/ CHPIRE (NPIREA)
32966 DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32967 EQUIVALENCE ( SG2BRS (1,1), SGABSR (1,1,1) )
32968 EQUIVALENCE ( SGABSW (1,1), SGABSR (1,1,2) )
32969 EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32970 * (original name: FRBKCM)
32971 PARAMETER ( MXFFBK = 6 )
32972 PARAMETER ( MXZFBK = 9 )
32973 PARAMETER ( MXNFBK = 10 )
32974 PARAMETER ( MXAFBK = 16 )
32975 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32976 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32977 PARAMETER ( NXAFBK = MXAFBK + 1 )
32978 PARAMETER ( MXPSST = 300 )
32979 PARAMETER ( MXPSFB = 41000 )
32980 LOGICAL LFRMBK, LNCMSS
32981 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
32982 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
32983 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
32984 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
32985 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
32986 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
32987 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
32988 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
32989 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
32990 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
32991 PARAMETER ( PI = PIPIPI )
32992 PARAMETER ( PISQ = PIPISQ )
32993 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
32994 PARAMETER ( RZNUCL = 1.12 D+00 )
32995 PARAMETER ( RMSPRO = 0.8 D+00 )
32996 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
32997 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
32999 PARAMETER ( RLLE04 = RZNUCL )
33000 PARAMETER ( RLLE16 = RZNUCL )
33001 PARAMETER ( RLGT16 = RZNUCL )
33002 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
33003 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
33004 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
33005 PARAMETER ( SKLE04 = 1.4D+00 )
33006 PARAMETER ( SKLE16 = 1.9D+00 )
33007 PARAMETER ( SKGT16 = 2.4D+00 )
33008 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
33009 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
33010 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
33011 PARAMETER ( ALPHA0 = 0.1D+00 )
33012 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
33013 PARAMETER ( GAMSK0 = 0.9D+00 )
33014 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
33015 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
33016 PARAMETER ( POTBA0 = 1.D+00 )
33017 PARAMETER ( PNFRAT = 1.533D+00 )
33018 PARAMETER ( RADPIM = 0.035D+00 )
33019 PARAMETER ( RDPMHL = 14.D+00 )
33020 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
33021 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
33022 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
33023 PARAMETER ( AP0PFS = 0.5D+00 )
33024 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
33025 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
33026 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
33027 PARAMETER ( MXSCIN = 50 )
33028 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
33029 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
33030 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
33031 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
33032 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
33033 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
33035 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33036 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33037 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33038 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33039 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33040 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33041 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33042 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33043 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33044 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33045 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33046 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33047 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33048 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33049 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33050 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33051 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33052 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33053 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33054 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33055 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33056 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33057 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33058 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33059 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33060 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
33061 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33062 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33063 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33064 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33065 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33066 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33067 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33068 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33069 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33070 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33071 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33072 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33073 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33074 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33076 DIMENSION AWSTAB (2:260), SIGMAB (3)
33077 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33078 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33079 EQUIVALENCE ( RHOIPP, RHONCP (1) )
33080 EQUIVALENCE ( RHOINP, RHONCP (2) )
33081 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33082 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33083 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33084 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33085 EQUIVALENCE ( RHOIPT, RHONCT (1) )
33086 EQUIVALENCE ( RHOINT, RHONCT (2) )
33087 EQUIVALENCE ( OMALHL, SK3PAR )
33088 EQUIVALENCE ( ALPHAL, HABPAR )
33089 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33090 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33091 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33092 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33093 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33094 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33095 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33096 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33097 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33098 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33099 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33100 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33101 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33102 * (original name: NUCLEV)
33103 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33104 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33105 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33106 & CUMRAD (0:160,2), RUSNUC (2),
33107 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33108 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33109 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33110 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33111 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33112 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33113 & LFLVSL, LRLVSL, LEQSBL
33114 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33115 & MGSSPR (19) , MGSSNE (25)
33116 EQUIVALENCE ( RUSNUC (1), RUSPRO )
33117 EQUIVALENCE ( RUSNUC (2), RUSNEU )
33118 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33119 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33120 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33121 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33122 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33123 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33124 EQUIVALENCE ( NTANUC (1), NTAPRO )
33125 EQUIVALENCE ( NTANUC (2), NTANEU )
33126 EQUIVALENCE ( NAVNUC (1), NAVPRO )
33127 EQUIVALENCE ( NAVNUC (2), NAVNEU )
33128 EQUIVALENCE ( NLSNUC (1), NLSPRO )
33129 EQUIVALENCE ( NLSNUC (2), NLSNEU )
33130 EQUIVALENCE ( NCONUC (1), NCOPRO )
33131 EQUIVALENCE ( NCONUC (2), NCONEU )
33132 EQUIVALENCE ( NSKNUC (1), NSKPRO )
33133 EQUIVALENCE ( NSKNUC (2), NSKNEU )
33134 EQUIVALENCE ( NHANUC (1), NHAPRO )
33135 EQUIVALENCE ( NHANUC (2), NHANEU )
33136 EQUIVALENCE ( NUSNUC (1), NUSPRO )
33137 EQUIVALENCE ( NUSNUC (2), NUSNEU )
33138 EQUIVALENCE ( NACNUC (1), NACPRO )
33139 EQUIVALENCE ( NACNUC (2), NACNEU )
33140 EQUIVALENCE ( JMXNUC (1), JMXPRO )
33141 EQUIVALENCE ( JMXNUC (2), JMXNEU )
33142 EQUIVALENCE ( MAGNUC (1), MAGPRO )
33143 EQUIVALENCE ( MAGNUC (2), MAGNEU )
33144 * (original name: PARNUC)
33145 PARAMETER ( PIGRK = PIPIPI )
33146 PARAMETER ( ALEVEL = 8.D-03 )
33147 PARAMETER ( RCNUCL = 1.12D+00 )
33148 PARAMETER ( R0SIG = 1.3D+00 )
33149 PARAMETER ( R0SIGK = 1.5D+00 )
33150 PARAMETER ( RCOULB = 1.5D+00 )
33151 PARAMETER ( COULBH = 0.88235D-03 )
33152 PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33153 PARAMETER ( TAUFO0 = 10.0D+00 )
33154 PARAMETER ( EKEEXP = 0.03D+00 )
33155 PARAMETER ( EKREXP = 0.05D+00 )
33156 PARAMETER ( EKEMNM = 0.01D+00 )
33157 PARAMETER ( NCPMX = 120 )
33158 COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33159 & ENNUC (NCPMX), PNUCL (NCPMX), EKFNUC (NCPMX),
33160 & XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33161 & PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33162 & RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33163 & CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33164 & TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33165 & KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33166 & INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33167 & IBNUCL, NPNUC , NNUCTS
33169 DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33170 DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33171 DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33172 DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33173 DATA LPREEQ / .FALSE. /
33175 DATA JSTOKP / 1, 8, 13, 14, 23 /
33176 DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33177 DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33178 & 'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33179 & 'PI0NPI0N','PI0NPI-P' /
33180 DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33181 & 13, 8, 13, 8, 23, 8, 23, 8 /
33182 DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33183 & 13, 8, 23, 1, 23, 8, 14, 1 /
33184 DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33185 DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33187 DATA LFRMBK / .FALSE. /
33188 DATA NBUFBK / 500 /
33189 DATA EXMXFB / 80.0 D+00 /
33190 DATA R0FRBK / 1.18 D+00 /
33191 DATA R0CFBK / 2.173D+00 /
33192 DATA C1CFBK / 6.103D-03 /
33193 DATA C2CFBK / 9.443D-03 /
33195 DATA TAUFOR / TAUFO0 /
33196 *=== End of Block Data Bdpree =========================================*
33199 *$ CREATE DT_XHOINI.FOR
33202 *====phoini============================================================*
33204 SUBROUTINE DT_XHOINI
33205 C SUBROUTINE DT_PHOINI
33207 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33209 PARAMETER ( LINP = 10 ,
33216 *$ CREATE DT_XVENTB.FOR
33219 *====eventb============================================================*
33221 SUBROUTINE DT_XVENTB(NCSY,IREJ)
33222 C SUBROUTINE DT_EVENTB(NCSY,IREJ)
33224 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33226 PARAMETER ( LINP = 10 ,
33231 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
33236 *$ CREATE DT_XVENT.FOR
33239 *===event==============================================================*
33241 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33242 C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33244 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33247 DIMENSION PP(4),PT(4)
33252 *$ CREATE DT_XOHISX.FOR
33255 *===pohisx=============================================================*
33257 SUBROUTINE DT_XOHISX(I,X)
33258 C SUBROUTINE POHISX(I,X)
33260 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33266 *$ CREATE PHO_LHIST.FOR
33269 *===poluhi=============================================================*
33271 SUBROUTINE PHO_LHIST(I,X)
33274 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33280 *$ CREATE PDFSET.FOR
33283 C**********************************************************************
33285 C dummy subroutines, remove to link PDFLIB
33287 C**********************************************************************
33288 SUBROUTINE PDFSET(PARAM,VALUE)
33289 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33290 DIMENSION PARAM(20),VALUE(20)
33294 *$ CREATE STRUCTM.FOR
33297 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33298 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33301 *$ CREATE STRUCTP.FOR
33304 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33305 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33308 *$ CREATE DT_DIQBRK.FOR
33311 *===diqbrk=============================================================*
33313 SUBROUTINE DT_XIQBRK
33314 C SUBROUTINE DT_DIQBRK
33316 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33319 STOP 'diquark-breaking not implemeted !'
33324 *$ CREATE DT_ELHAIN.FOR
33327 *===elhain=============================================================*
33329 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33331 ************************************************************************
33332 * Elastic hadron-hadron scattering. *
33333 * This is a revised version of the original. *
33334 * This version dated 03.04.98 is written by S. Roesler *
33335 ************************************************************************
33337 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33339 PARAMETER ( LINP = 10 ,
33342 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33345 PARAMETER (ENNTHR = 3.5D0)
33346 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33347 & BLOWB=0.05D0,BHIB=0.2D0,
33348 & BLOWM=0.1D0, BHIM=2.0D0)
33350 * particle properties (BAMJET index convention)
33352 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33353 & IICH(210),IIBAR(210),K1(210),K2(210)
33354 * final state from HADRIN interaction
33355 PARAMETER (MAXFIN=10)
33356 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33357 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33359 C DATA TSLOPE /10.0D0/
33365 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33366 EKIN = ELAB-AAM(IP)
33367 * kinematical quantities in cms of the hadrons
33370 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
33372 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33373 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33375 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33376 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33377 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33378 * TSAMCS treats pp and np only, therefore change pn into np and
33384 IF (IP.EQ.8) KPROJ = 1
33386 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33387 T = TWO*PCM**2*(CTCMS-ONE)
33389 * very crude treatment otherwise: sample t from exponential dist.
33391 * momentum transfer t
33392 TMAX = TWO*TWO*PCM**2
33393 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33394 IF (IIBAR(IP).NE.0) THEN
33395 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33397 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33399 FMAX = EXP(-TSLOPE*TMAX)-ONE
33401 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33402 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33405 * target hadron in Lab after scattering
33406 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33407 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33408 IF (PLRH(2).LE.TINY10) THEN
33409 C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33412 * projectile hadron in Lab after scattering
33413 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33414 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33415 * scattering angle of projectile in Lab
33416 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33417 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33418 CALL DT_DSFECF(SPLABP,CPLABP)
33419 * direction cosines of projectile in Lab
33420 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33421 & CXRH(1),CYRH(1),CZRH(1))
33422 * scattering angle of target in Lab
33423 PLLABT = PLAB-CTLABP*PLRH(1)
33424 CTLABT = PLLABT/PLRH(2)
33425 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33426 * direction cosines of target in Lab
33427 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33428 & CXRH(2),CYRH(2),CZRH(2))
33437 *$ CREATE DT_TSAMCS.FOR
33440 *===tsamcs=============================================================*
33442 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33444 ************************************************************************
33445 * Sampling of cos(theta) for nucleon-proton scattering according to *
33446 * hetkfa2/bertini parametrization. *
33447 * This is a revised version of the original (HJM 24/10/88) *
33448 * This version dated 28.10.95 is written by S. Roesler *
33449 ************************************************************************
33451 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33453 PARAMETER ( LINP = 10 ,
33456 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33459 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33460 DIMENSION PDCI(60),PDCH(55)
33462 DATA (DCLIN(I),I=1,80) /
33463 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
33464 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
33465 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
33466 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
33467 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
33468 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
33469 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
33470 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
33471 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
33472 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
33473 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
33474 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
33475 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
33476 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
33477 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
33478 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
33479 DATA (DCLIN(I),I=81,160) /
33480 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
33481 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
33482 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
33483 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
33484 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
33485 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
33486 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
33487 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
33488 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
33489 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
33490 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
33491 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
33492 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
33493 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
33494 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
33495 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
33496 DATA (DCLIN(I),I=161,195) /
33497 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
33498 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
33499 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
33500 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
33501 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
33502 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
33503 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
33506 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
33507 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
33508 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
33509 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
33510 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
33511 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
33512 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
33513 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
33514 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
33515 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
33516 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
33517 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
33520 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
33521 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
33522 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
33523 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
33524 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
33525 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
33526 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
33527 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
33528 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
33529 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
33530 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
33532 DATA (DCHN(I),I=1,90) /
33533 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
33534 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
33535 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
33536 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
33537 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
33538 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
33539 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
33540 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
33541 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
33542 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
33543 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
33544 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
33545 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
33546 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
33547 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
33548 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
33549 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
33550 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
33551 DATA (DCHN(I),I=91,143) /
33552 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
33553 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
33554 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
33555 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
33556 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
33557 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
33558 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
33559 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
33560 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
33561 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
33562 & 6.488D-02, 6.485D-02, 6.480D-02/
33565 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
33566 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
33567 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
33568 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
33569 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
33570 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
33571 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
33575 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
33576 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
33577 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
33578 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
33579 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
33580 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
33581 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33582 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
33583 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33584 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
33585 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33586 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
33589 IF (EKIN.GT.3.5D0) RETURN
33591 IF(KPROJ.EQ.8) GOTO 101
33592 IF(KPROJ.EQ.1) GOTO 102
33593 C* INVALID REACTION
33594 WRITE(LOUT,'(A,I5/A)')
33595 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33596 & ' COS(THETA) = 1D0 RETURNED'
33598 C-------------------------------- NP ELASTIC SCATTERING----------
33600 IF (EKIN.GT.0.740D0)GOTO 1000
33601 IF (EKIN.LT.0.300D0)THEN
33602 C EKIN .LT. 300 MEV
33605 C 300 MEV < EKIN < 740 MEV
33610 IE=INT(ABS(ENER/0.020D0))
33611 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33612 C FORWARD/BACKWARD DECISION
33614 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33615 IF (DT_RNDM(CST).LT.BWFW)THEN
33623 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33626 IF(RND.LT.COEF)THEN
33635 IF(VALUE2.GT.0.0)THEN
33636 CST=MAX(R1,R2,R3,R4)
33642 CST=-MAX(R1,R2,R3,R4,R5)
33646 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33655 C******** EKIN .GT. 0.74 GEV
33657 1000 ENER=EKIN - 0.66D0
33658 C IE=ABS(ENER/0.02)
33659 IE=INT(ENER/0.02D0)
33662 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33664 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33667 IF (RND.GE.BWFW)THEN
33669 IF (DCHNA(K).GT.EMEV) THEN
33670 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33671 UNIV=DT_RNDM(UNIVE)
33674 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33677 UNIV=DT_RNDM(UNIVE)
33679 GOTO(290,290,290,290,330,340,350,360) I
33688 IF (DCHNB(K).GT.EMEV) THEN
33689 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33690 UNIV=DT_RNDM(UNIVE)
33693 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33698 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33705 120 CST=1.0D-2*FLTI-1.0D0
33707 140 CST=2.0D-2*UNIV-0.98D0
33709 150 CST=4.0D-2*UNIV-0.96D0
33711 160 CST=6.0D-2*FLTI-1.16D0
33713 180 CST=8.0D-2*UNIV-0.80D0
33715 190 CST=1.0D-1*UNIV-0.72D0
33717 200 CST=1.2D-1*UNIV-0.62D0
33719 210 CST=2.0D-1*UNIV-0.50D0
33721 220 CST=3.0D-1*(UNIV-1.0D0)
33724 290 CST=1.0D0-2.5d-2*FLTI
33726 330 CST=0.85D0+0.5D-1*UNIV
33728 340 CST=0.70D0+1.5D-1*UNIV
33730 350 CST=0.50D0+2.0D-1*UNIV
33732 360 CST=0.50D0*UNIV
33736 C----------------------------------- PP ELASTIC SCATTERING -------
33741 IF (EKIN.LE.0.500D0) THEN
33743 CST=2.0D0*RND-1.0D0
33746 ELSEIF (EKIN.LT.1.0D0) THEN
33748 IF (PDCI(K).GT.EMEV) THEN
33749 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33750 UNIV=DT_RNDM(UNIVE)
33754 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33756 IF (UNIV.LT.SUM)THEN
33759 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33766 IF (PDCH(K).GT.EMEV) THEN
33767 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33768 UNIV=DT_RNDM(UNIVE)
33772 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33774 IF (UNIV.LT.SUM)THEN
33777 GOTO(50,55,60,60,65,65,65,65,70,70) I
33788 60 CST=0.3D0+0.1D0*FLTI
33790 65 CST=0.6D0+0.04D0*FLTI
33792 70 CST=0.78D0+0.02D0*FLTI
33795 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33800 *$ CREATE DT_DHADRI.FOR
33803 *===dhadri=============================================================*
33805 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33807 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33810 PARAMETER ( LINP = 10 ,
33814 C-----------------------------
33815 C*** INPUT VARIABLES LIST:
33816 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33817 C*** GEV/C LABORATORY MOMENTUM REGION
33818 C*** N - PROJECTILE HADRON INDEX
33819 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33820 C*** ELAB - LABORATORY ENERGY OF N (GEV)
33821 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33822 C*** ITTA - TARGET NUCLEON INDEX
33823 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33824 C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33825 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33826 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33827 C*** RESPECT., UNITS (GEV/C AND GEV)
33828 C----------------------------
33830 COMMON /HNGAMR/ REDU,AMO,AMM(15)
33831 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33832 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33833 & NRK(2,268),NURE(30,2)
33834 * particle properties (BAMJET index convention),
33835 * (dublicate of DTPART for HADRIN)
33836 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33837 & K1H(110),K2H(110)
33838 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33839 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33841 COMMON /HNDRUN/ RUNTES,EFTES
33842 * particle properties (BAMJET index convention)
33844 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33845 & IICH(210),IIBAR(210),K1(210),K2(210)
33846 * final state from HADRIN interaction
33847 PARAMETER (MAXFIN=10)
33848 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33849 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33851 DIMENSION ITPRF(110)
33854 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33856 IF (N.LE.0.OR.N.GE.111)N=1
33857 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33860 * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33862 *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33863 * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33866 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
33867 C IF(IPRI.GE.1) WRITE (6,1010) PLAB
33869 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33870 + ALLOWED REGION, PLAB=',1E15.5)
33873 UMODAT=N*1.11111D0+ITTA*2.19291D0
33874 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33881 IF (LOWP.GT.20) THEN
33882 C WRITE(LOUT,*) ' jump 1'
33886 IF (NNN.EQ.N) GO TO 50
33895 IF(ITTA.GT.1) IRE=NURE(N,2)
33897 C-----------------------------
33898 C*** IE,AMT,ECM,SI DETERMINATION
33899 C----------------------------
33900 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33903 C IF (AMH(1).NE.0.93828D0) IANTH=1
33904 IF (AMH(1).NE.0.9383D0) IANTH=1
33906 IF (IANTH.GE.0) SI=1.0D0
33909 C-----------------------------
33911 C IRE CHARACTERIZES THE REACTION
33912 C IE IS THE ENERGY INDEX
33913 C----------------------------
33914 IF (SI.LT.1.D-6) THEN
33915 C WRITE(LOUT,*) ' jump 2'
33918 IF (N.LE.NSTAB) GO TO 60
33919 RUNTES=RUNTES+1.0D0
33920 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33921 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33922 IF(IBARH(N).EQ.1) N=8
33923 IF(IBARH(N).EQ.-1) N=9
33926 **sr 19.2.97: loop for direct channel suppression
33927 C IF (IMACH.GT.10) THEN
33928 IF (IMACH.GT.1000) THEN
33930 C WRITE(LOUT,*) ' jump 3'
33936 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
33937 IF(ECMN.LE.AMN) ECMN=AMN
33938 PCMN=SQRT(ECMN**2-AMN2)
33941 IF (IANTH.GE.0) ECM=2.1D0
33943 C-----------------------------
33944 C*** RANDOM CHOICE OF REACTION CHANNEL
33945 C----------------------------
33950 C-----------------------------
33951 C*** PLACE REDUCED VERSION
33952 C----------------------------
33954 IDWK=IEII(IRE+1)-IIEI
33958 C-----------------------------
33959 C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33960 C----------------------------
33962 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33963 IF (HUMO.LT.ECM) ECM=HUMO
33965 C-----------------------------
33966 C*** INTERPOLATION PREPARATION
33967 C----------------------------
33973 C-----------------------------
33975 C----------------------------
33980 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33984 C-----------------------------
33985 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
33986 C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
33988 C----------------------------
33989 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
33990 WICO=WOK*1.23459876D0+WDK*1.735218469D0
33991 IF (WICO.EQ.WICOR) GO TO 70
33992 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
33995 C-----------------------------
33996 C*** INTERPOLATION IN CHANNEL WEIGHTS
33997 C----------------------------
33998 EKLIM=-THRESH(IIKI+IK)
33999 IELIM=IDT_IEFUND(EKLIM,IRE)
34000 DELIM=UMO(IELIM)+EKLIM
34002 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34003 IF (DELIM*DELIM-DETE*DETE) 90,90,80
34008 WKK=WOK-WDK*DEC/(DECC+1.D-9)
34010 C-----------------------------
34012 C----------------------------
34014 IF (VV.GT.WKK) GO TO 70
34016 C***IK IS THE REACTION CHANNEL
34017 C----------------------------
34029 IF (I1001.GT.50) GO TO 60
34031 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
34034 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34037 IF (IT2.GT.0) GO TO 120
34038 **sr 19.2.97: supress direct channel for pp-collisions
34039 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34041 IF (RR.LE.0.75D0) GOTO 60
34045 C-----------------------------
34046 C INCLUSION OF DIRECT RESONANCES
34047 C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
34048 C------------------------
34061 IF(WW.LT. 0.5D0) GO TO 130
34068 C-----------------------------
34069 C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34076 IF(IB1.EQ.IBN) GO TO 140
34082 C-----------------------------
34083 C***IT1,IT2 ARE THE CREATED PARTICLES
34084 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34085 C------------------------
34086 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34087 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34092 C-----------------------------
34093 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34094 C----------------------------
34095 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34096 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34100 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34101 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34104 C-----------------------------
34105 C***TEST STABLE OR UNSTABLE
34106 C----------------------------
34107 IF(ITS(IST).GT.NSTAB) GO TO 160
34110 C-----------------------------
34111 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34112 C----------------------------
34113 C* IF (REDU.LT.0.D0) GO TO 1009
34121 IF(IST.GE.1) GO TO 150
34125 C RANDOM CHOICE OF DECAY CHANNELS
34126 C----------------------------
34140 IF (VV.GT.WTI(IIK)) GO TO 180
34142 C IIK IS THE DECAY CHANNEL
34143 C----------------------------
34151 IF (IT2-1.LT.0) GO TO 240
34156 C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34157 C----------------------------
34158 IF (IECO.LE.10) GO TO 200
34160 IF(IATMPT.GT.3) THEN
34161 C WRITE(LOUT,*) ' jump 4'
34166 IF (I310.GT.50) GO TO 170
34167 IF (AMS.GT.ECO) GO TO 190
34169 C FOR THE DECAY CHANNEL
34170 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
34171 C----------------------------
34172 IF (REDU.LT.0.D0) GO TO 30
34175 IF(IT3.EQ.0) GO TO 220
34178 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34179 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34181 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34182 &COD2,COF2,SIF2,AM1,AM2)
34187 IF (REDU.GT.0.D0) GO TO 240
34189 IF (ITWTHC.GT.100) GO TO 30
34190 IF (ITWTH) 220,220,210
34193 IF (IT2-1.LT.0) GO TO 250
34200 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34201 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34204 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34205 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34206 IF (IT3.LE.0) GO TO 250
34209 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34210 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34218 C----------------------------
34220 C ZERO CROSS SECTION CASE
34221 C----------------------------
34233 *$ CREATE DT_RUNTT.FOR
34236 *===runtt==============================================================*
34238 BLOCK DATA DT_RUNTT
34240 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34243 COMMON /HNDRUN/ RUNTES,EFTES
34245 DATA RUNTES,EFTES /100.D0,100.D0/
34249 *$ CREATE DT_NONAME.FOR
34252 *===noname=============================================================*
34254 BLOCK DATA DT_NONAME
34256 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34259 * slope parameters for HADRIN interactions
34260 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34261 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34263 C DATAS DATAS DATAS DATAS DATAS
34265 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34266 & 207, 224, 241, 252, 268 /
34267 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34268 & 220, 241, 262, 279, 296 /
34269 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34270 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
34273 C MASSES FOR THE SLOPE B(M) IN GEV
34274 C SLOPE B(M) FOR AN MESONIC SYSTEM
34275 C SLOPE B(M) FOR A BARYONIC SYSTEM
34278 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
34279 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
34280 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
34281 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
34282 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
34283 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34284 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
34285 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
34286 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
34287 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
34288 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
34289 & 14.2D0, 13.4D0, 12.6D0,
34290 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
34291 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
34295 *$ CREATE DT_DAMG.FOR
34298 *===damg===============================================================*
34300 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34302 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34305 * particle properties (BAMJET index convention),
34306 * (dublicate of DTPART for HADRIN)
34307 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34308 & K1H(110),K2H(110)
34310 DIMENSION GASUNI(14)
34312 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34313 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34314 DATA GAUNO/2.352D0/
34320 IF (IT.LE.0) GO TO 30
34321 IF (IT.LE.NSTAB) GO TO 20
34322 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34324 VV=VV*2.0D0-1.0D0+1.D-16
34329 IF (VV.GT.V1) GO TO 10
34330 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34331 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34332 DAM=GAH(IT)*UNIGA/GAUNO
34344 *$ CREATE DT_DCALUM.FOR
34347 *===dcalum=============================================================*
34349 SUBROUTINE DT_DCALUM(N,ITTA)
34351 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34354 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34356 * particle properties (BAMJET index convention),
34357 * (dublicate of DTPART for HADRIN)
34358 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34359 & K1H(110),K2H(110)
34360 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34361 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34362 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34363 & NRK(2,268),NURE(30,2)
34365 IRE=NURE(N,ITTA/8+1)
34374 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34381 IF(NRK(2,IK).GT.0) GO TO 30
34390 IF(IN.GT.0)AMS=AMS+AMH(IN)
34392 IF(IN.GT.0) AMS=AMS+AMH(IN)
34393 IF (AMS.LT.AMSS) AMSS=AMS
34395 IF(UMOO.LT.AMSS) UMOO=AMSS
34401 *$ CREATE DT_DCHANH.FOR
34404 *===dchanh=============================================================*
34406 SUBROUTINE DT_DCHANH
34408 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34411 PARAMETER ( LINP = 10 ,
34414 * particle properties (BAMJET index convention),
34415 * (dublicate of DTPART for HADRIN)
34416 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34417 & K1H(110),K2H(110)
34418 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34419 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34420 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34421 & NRK(2,268),NURE(30,2)
34423 DIMENSION HWT(460),HWK(40),SI(5184)
34424 EQUIVALENCE (WK(1),SI(1))
34425 C--------------------
34426 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34427 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34428 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34429 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34430 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34431 C--------------------------
34435 IEE=IEII(IRE+1)-IEII(IRE)
34436 IKE=IKII(IRE+1)-IKII(IRE)
34439 * modifications to suppress elestic scattering 24/07/91
34444 IWK=IWKO+IEE*(IK-1)+IE
34445 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34446 SIS=SIS+SI(IWK)*SINORC
34450 IF (SIS.GE.1.D-12) GO TO 20
34456 IWK=IWKO+IEE*(IK-1)+IE
34457 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34458 SIO=SIO+SI(IWK)*SINORC/SIS
34462 IWK=IWKO+IEE*(IK-1)+IE
34467 INRK1=NRK(1,IIKI+IK)
34468 IF (INRK1.GT.0) AM111=AMH(INRK1)
34470 INRK2=NRK(2,IIKI+IK)
34471 IF (INRK2.GT.0) AM222=AMH(INRK2)
34472 THRESH(IIKI+IK)=AM111 +AM222
34473 IF (INRK2-1.GE.0) GO TO 60
34477 DO 50 INRK1=INRKK,INRKO
34478 INZK1=NZKI(INRK1,1)
34479 INZK2=NZKI(INRK1,2)
34480 INZK3=NZKI(INRK1,3)
34481 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
34482 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
34483 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
34484 C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34486 AMS=AMH(INZK1)+AMH(INZK2)
34487 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34488 IF (AMSS.GT.AMS) AMSS=AMS
34491 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34492 THRESH(IIKI+IK)=AMS
34503 IF (IK2.GT.460)IK2=460
34510 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34511 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34518 *$ CREATE DT_DHADDE.FOR
34521 *===dhadde=============================================================*
34523 SUBROUTINE DT_DHADDE
34525 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34528 * particle properties (BAMJET index convention)
34530 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34531 & IICH(210),IIBAR(210),K1(210),K2(210)
34532 * HADRIN: decay channel information
34533 PARAMETER (IDMAX9=602)
34535 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34536 * particle properties (BAMJET index convention),
34537 * (dublicate of DTPART for HADRIN)
34538 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34539 & K1H(110),K2H(110)
34540 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34541 * decay channel information for HADRIN
34542 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34543 & K1Z(16),K2Z(16),WTZ(153),II22,
34544 & NZK1(153),NZK2(153),NZK3(153)
34550 IF (IRETUR.GT.1) RETURN
34556 IBARH(I) = IIBAR(I)
34571 NZKI(I,1) = NZK(I,1)
34572 NZKI(I,2) = NZK(I,2)
34573 NZKI(I,3) = NZK(I,3)
34588 NZKI(L,3) = NZK3(I)
34589 NZKI(L,2) = NZK2(I)
34590 NZKI(L,1) = NZK1(I)
34595 *$ CREATE IDT_IEFUND.FOR
34598 *===iefund=============================================================*
34600 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34602 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34605 C*****IEFUN CALCULATES A MOMENTUM INDEX
34607 PARAMETER ( LINP = 10 ,
34610 COMMON /HNDRUN/ RUNTES,EFTES
34611 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34612 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34613 & NRK(2,268),NURE(30,2)
34618 IF (PL.LT.0.) GO TO 30
34621 IF (PL.LE.PLABF(I)) GO TO 60
34624 IF ( EFTES.GT.40.D0) GO TO 20
34626 WRITE(LOUT,1000)PL,J
34632 IF (-PL.LE.UMO(I)) GO TO 60
34635 IF ( EFTES.GT.40.D0) GO TO 50
34637 WRITE(LOUT,1000)PL,I
34643 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34647 *$ CREATE DT_DSIGIN.FOR
34650 *===dsigin=============================================================*
34652 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34654 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34657 * particle properties (BAMJET index convention),
34658 * (dublicate of DTPART for HADRIN)
34659 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34660 & K1H(110),K2H(110)
34661 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34662 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34663 & NRK(2,268),NURE(30,2)
34665 IE=IDT_IEFUND(PLAB,IRE)
34666 IF (IE.LE.IEII(IRE)) IE=IE+1
34671 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34672 C*** INTERPOLATION PREPARATION
34678 EKLIM=-THRESH(IIKI)
34681 IF (ECM.GT.ECMO) WDK=0.0D0
34682 C*** INTERPOLATION IN CHANNEL WEIGHTS
34683 IELIM=IDT_IEFUND(EKLIM,IRE)
34684 DELIM=UMO(IELIM)+EKLIM
34686 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34687 IF (DELIM*DELIM-DETE*DETE) 20,20,10
34692 WKK=WOK-WDK*DEC/(DECC+1.D-9)
34693 IF (WKK.LT.0.0D0) WKK=0.0D0
34695 IF (-EKLIM.GT.ECM) SI=1.D-14
34699 *$ CREATE DT_DTCHOI.FOR
34702 *===dtchoi=============================================================*
34704 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34706 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34709 C ****************************
34710 C TCHOIC CALCULATES A RANDOM VALUE
34711 C FOR THE FOUR-MOMENTUM-TRANSFER T
34712 C ****************************
34714 * particle properties (BAMJET index convention),
34715 * (dublicate of DTPART for HADRIN)
34716 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34717 & K1H(110),K2H(110)
34718 * slope parameters for HADRIN interactions
34719 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34723 IF (I.GT.30.AND.II.GT.30) GO TO 20
34726 IF (I.LE.30) GO TO 10
34734 IF (AMA.LE.AMB) GO TO 30
34740 K=INT((AMA-0.75D0)/0.05D0)
34742 IF (K-26.GE.0) K=25
34749 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
34750 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
34753 C IF (VB.LT.0.2D0) BM=BM*0.1
34760 IF (ABS(TMA).GT.120.D0) GO TO 70
34763 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34764 C*** RANDOM CHOICE OF THE T - VALUE
34766 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34770 *$ CREATE DT_DTWOPA.FOR
34773 *===dtwopa=============================================================*
34775 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34776 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34778 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34781 C ******************************************************
34782 C QUASI TWO PARTICLE PRODUCTION
34783 C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34784 C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34785 C IN THE CM - SYSTEM
34786 C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34787 C SPHERICAL COORDINATES
34788 C ******************************************************
34790 * particle properties (BAMJET index convention),
34791 * (dublicate of DTPART for HADRIN)
34792 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34793 & K1H(110),K2H(110)
34798 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34800 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34801 AMTE=(E1-AMA)*(E1+AMA)
34805 C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
34806 C DETERMINATION OF THE ANGLES
34807 C COS(THETA1)=COD1 COS(THETA2)=COD2
34808 C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
34809 C COS(PHI1)=COF1 COS(PHI2)=COF2
34810 C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34811 CALL DT_DSFECF(COF1,SIF1)
34814 C CALCULATION OF THETA1
34815 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34816 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34817 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34822 *$ CREATE DT_ZK.FOR
34825 *===zk=================================================================*
34829 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34832 * decay channel information for HADRIN
34833 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34834 & K1Z(16),K2Z(16),WTZ(153),II22,
34835 & NZK1(153),NZK2(153),NZK3(153)
34836 * decay channel information for HADRIN
34837 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34838 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34840 * Particle masses in GeV *
34841 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34843 * Resonance width Gamma in GeV *
34844 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34845 * Mean life time in seconds *
34846 DATA TAUZ / 16*0.D0 /
34847 * Charge of particles and resonances *
34848 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34849 * Baryonic charge *
34850 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34851 * First number of decay channels used for resonances *
34852 * and decaying particles *
34853 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34855 * Last number of decay channels used for resonances *
34856 * and decaying particles *
34857 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34859 * Weight of decay channel *
34860 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34861 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34862 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34863 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34864 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34865 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34866 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34867 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34868 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34869 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34870 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34871 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34872 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34873 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34874 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34875 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34876 & .05D0, .65D0, 9*1.D0 /
34877 * Particle numbers in decay channel *
34878 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34879 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34880 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34881 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34882 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34883 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34884 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34885 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34886 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34887 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34888 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34889 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34890 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34891 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34892 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34893 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34894 & 1, 8, 1, 8, 1, 9*0 /
34895 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34896 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34897 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34898 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34899 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34900 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34902 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
34903 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34905 * Name of decay channel *
34906 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34907 & 'ANNPI0','APPPI0','ANPPI-'/
34908 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
34909 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
34910 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
34911 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34912 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34913 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34914 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34916 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
34917 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34918 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34919 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34920 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
34921 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34922 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34923 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34924 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
34925 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34926 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34927 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34928 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34933 *$ CREATE DT_BLKD43.FOR
34936 *===blkd43=============================================================*
34938 BLOCK DATA DT_BLKD43
34940 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34944 *=== reac =============================================================*
34946 *----------------------------------------------------------------------*
34948 * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
34951 * Last change on 10-dec-91 by Alfredo Ferrari *
34953 * This is the original common reac of Hadrin *
34955 *----------------------------------------------------------------------*
34957 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34958 & NRK(2,268),NURE(30,2)
34961 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34962 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34963 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34964 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34965 & SPIKP5(187), SPIKP6(289),
34966 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34967 & SPIKP9(143), SPIKP0(169), SPKPV(143),
34968 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34969 & SANPEL(84) , SPIKPF(273),
34970 & SPKP15(187), SPKP16(272),
34971 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34974 DIMENSION NRKLIN(532)
34975 EQUIVALENCE (NRK(1,1), NRKLIN(1))
34976 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
34977 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
34978 EQUIVALENCE ( UMO(263), UMOK0(1))
34979 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
34980 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
34981 EQUIVALENCE ( PLABF(263), PLAK0(1))
34982 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
34983 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
34984 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
34985 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
34986 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
34987 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
34988 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
34989 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
34990 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
34991 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
34992 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
34993 EQUIVALENCE ( WK(4913), SPKP16(1))
34994 EQUIVALENCE (NRK(1,1), NRKLIN(1))
34995 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
34996 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
34997 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
34998 EQUIVALENCE (NURE(1,1), NURELN(1))
35002 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
35003 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
35004 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
35005 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
35006 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
35007 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
35008 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
35009 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
35010 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
35011 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
35013 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35014 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35015 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35016 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35017 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35018 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35019 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35020 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35021 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35022 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35023 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35024 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35026 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35027 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35028 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35029 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35030 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35031 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35034 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35035 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35036 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35037 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35038 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35039 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35040 * app apn anp ann *
35042 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35043 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35044 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35045 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35046 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35047 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35048 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35049 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35050 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35051 DATA SIIN / 296*0.D0 /
35052 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35053 & 1.557D0,1.615D0,1.6435D0,
35054 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35055 & 2.286D0,2.366D0,2.482D0,2.56D0,
35057 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35058 & 1.496D0,1.527D0,1.557D0,
35059 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35060 & 2.071D0,2.159D0,2.286D0,2.366D0,
35061 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35062 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35063 & 1.496D0,1.527D0,1.557D0,
35064 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35065 & 2.071D0,2.159D0,2.286D0,2.366D0,
35066 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35067 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35068 & 1.557D0,1.615D0,1.6435D0,
35069 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35070 & 2.286D0,2.366D0,2.482D0,2.56D0,
35072 DATA UMOKC/ 1.44D0,
35073 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35074 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35076 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35077 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35079 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35080 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35082 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35083 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35085 DATA UMOK0/ 1.44D0,
35086 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35087 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35089 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35090 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35094 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35095 & 3.D0,3.1D0,3.2D0,
35096 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35097 & 3.D0,3.1D0,3.2D0,
35098 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35099 & 3.D0,3.1D0,3.2D0/
35100 * app apn anp ann *
35102 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35103 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35104 & 3.D0,3.1D0,3.2D0,
35105 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35106 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35107 & 3.D0,3.1D0,3.2D0,
35108 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35109 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35110 & 3.D0,3.1D0,3.2D0/
35111 **** reaction channel state particles *
35112 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35113 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35114 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35115 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35116 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35117 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35118 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35119 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35120 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35121 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35122 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35123 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35124 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35125 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35126 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35127 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35128 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35129 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35131 * k0 p k0 n ak0 p ak/ n *
35133 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35134 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
35135 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35136 & 53, 47, 1, 103, 0, 93, 0/
35138 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35139 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35140 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35141 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35142 * app apn anp ann *
35143 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35144 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35145 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35146 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35147 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35148 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35149 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35150 **** channel cross section *
35151 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35152 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35153 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35154 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35155 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35156 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35157 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35158 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35159 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35160 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35161 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35162 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35163 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35164 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35165 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35166 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35167 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35168 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35169 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35170 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35172 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
35173 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35174 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35175 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35176 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
35177 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
35178 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
35179 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
35180 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
35181 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
35182 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
35183 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
35184 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
35185 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
35186 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35187 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
35188 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
35189 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
35190 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
35191 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35193 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35194 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35195 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35196 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35197 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35198 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35199 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35200 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35201 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35202 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35203 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35204 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35205 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35206 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35207 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35208 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35209 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35210 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35211 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35212 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35214 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35215 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35216 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35217 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35218 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35219 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35220 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35221 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35222 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35223 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35224 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35225 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35226 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35227 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35228 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35229 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35230 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35231 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35232 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35234 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35235 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35236 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35237 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35238 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35239 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35240 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35241 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35242 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35243 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35244 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35245 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35246 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35247 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35248 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35249 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35250 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35251 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35252 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35253 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35255 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35256 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35257 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35258 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35259 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35260 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35261 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35262 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35263 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35264 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35265 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35266 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35267 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35268 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35269 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35270 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35271 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35272 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35273 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35274 & 3.3D0, 5.4D0, 7.D0 /
35276 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35277 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35278 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35279 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35280 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35281 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35282 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35283 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35284 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35285 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35286 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35287 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35288 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35290 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35291 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35292 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35293 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35294 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35295 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35296 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35297 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35298 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35299 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35300 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35301 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35302 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35303 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35304 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35305 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35306 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35307 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35308 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35310 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35311 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35312 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35313 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35314 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35315 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35316 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35317 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35318 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35319 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35320 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35321 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35322 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35323 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35324 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35325 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35326 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
35327 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35328 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35329 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35330 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35331 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35332 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35333 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35334 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35335 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35336 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35337 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35338 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35339 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35340 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35341 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35344 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35345 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35346 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35347 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35348 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35349 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35350 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35351 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35352 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35353 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35354 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35355 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35356 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35357 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35358 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35359 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35360 & .39D0, .22D0, .07D0, 0.D0,
35361 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35362 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35363 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35364 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35365 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35366 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35367 & 5.10D0, 5.44D0, 5.3D0,
35368 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35370 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35371 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35372 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
35373 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35374 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35375 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35376 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35377 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35378 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35379 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35380 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35381 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35382 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35383 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35384 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35386 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35387 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35388 & 0.D0, 1.8D0, .2D0, 12*0.D0,
35389 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35390 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35391 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35392 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35393 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35394 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35395 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35396 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35397 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35398 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35399 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35400 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35401 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35402 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35403 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35406 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35407 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35408 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
35409 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35410 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35411 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35412 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35413 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35414 & 11.D0, 5.5D0, 3.5D0,
35415 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35416 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35417 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35418 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35419 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35420 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35421 **************** ap - p - data *
35422 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35423 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35424 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35425 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35426 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35427 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35428 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35429 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35430 & 1.55D0, 1.3D0, .95D0, .75D0,
35431 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35432 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35433 & .01D0, .008D0, .006D0, .005D0/
35434 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35435 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35436 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35437 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35438 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35439 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35440 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35441 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35442 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35443 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35444 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35445 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35446 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35447 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35448 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35449 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35450 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35451 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35452 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35453 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35454 **************** ap - n - data *
35456 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35457 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35458 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35459 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
35460 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
35461 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35462 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35463 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35464 & .01D0, .008D0, .006D0, .005D0 /
35465 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35466 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35467 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35468 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35469 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35470 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35471 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35472 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35473 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35474 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35475 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35476 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35477 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35478 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35481 **************** an - p - data *
35484 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35485 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35486 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
35487 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35488 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35489 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35490 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35491 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35492 & .01D0, .008D0, .006D0, .005D0 /
35493 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35494 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35495 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35496 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35497 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35498 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35499 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35500 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35501 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35502 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35503 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35504 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35505 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35506 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35507 **** ko - n - data *
35508 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35509 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35510 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35511 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35512 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35513 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35514 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35515 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35516 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
35517 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35518 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35520 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35521 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35522 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
35523 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35524 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
35525 **** ako - p - data *
35526 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35527 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35528 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35529 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35530 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35531 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35532 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35533 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35534 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35535 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35536 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35537 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35538 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35539 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35540 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35541 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35542 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35543 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35544 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35545 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35546 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35547 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35548 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35549 *= end*block.blkdt3 *
35552 *$ CREATE DT_QEL_POL.FOR
35555 *===qel_pol============================================================*
35557 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35559 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35563 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35568 *$ CREATE DT_GEN_QEL.FOR
35570 C==================================================================
35571 C Generation of a Quasi-Elastic neutrino scattering
35572 C==================================================================
35574 *===gen_qel============================================================*
35576 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35578 C...Generate a quasi-elastic neutrino/antineutrino
35579 C. Interaction on a nuclear target
35580 C. INPUT : LTYP = neutrino type (1,...,6)
35581 C. ENU (GeV) = neutrino energy
35582 C----------------------------------------------------
35584 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35587 PARAMETER ( LINP = 10 ,
35590 PARAMETER (MAXLND=4000)
35591 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35592 * nuclear potential
35594 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35595 & EBINDP(2),EBINDN(2),EPOT(2,210),
35596 & ETACOU(2),ICOUL,LFERMI
35597 * steering flags for qel neutrino scattering modules
35598 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35599 **sr - removed (not needed)
35600 C COMMON /CBAD/ LBAD, NBAD
35601 C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35604 DIMENSION PI(3),PO(3)
35609 C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35610 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35611 DATA AMN /0.93827231D0, 0.93956563D0/
35612 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35615 C DATA PFERMI/0.22D0/
35616 CGB+...Binding Energy
35617 DATA EBIND/0.008D0/
35621 IF(ININU.EQ.1)NDSIG=0
35626 AML = AML0(LTYP) ! massa leptoni
35627 AML2 = AML**2 ! massa leptoni **2
35628 C...Particle labels (LUND)
35638 K0 = (LTYP-1)/2 ! 2
35640 KA = 12 + 2*K0 ! 16
35641 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
35645 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
35646 IF (LNU .EQ. 2) THEN
35674 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
35675 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35680 C...4-momentum initial lepton
35681 P(1,5) = 0. ! massa
35682 P(1,4) = ENU0 ! energia
35687 C PF = PFERMI*PYR(0)**(1./3.)
35688 c write(23,*) PYR(0)
35689 c write(*,*) 'Pfermi=',PF
35692 C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35693 IF (NTRY .GT. 500) THEN
35695 WRITE (LOUT,1001) NBAD, ENU
35698 C CT = -1. + 2.*PYR(0)
35700 C ST = SQRT(1.-CT*CT)
35701 C F = 2.*3.1415926*PYR(0)
35704 C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
35705 C P(2,1) = PF*ST*COS(F) ! px
35706 C P(2,2) = PF*ST*SIN(F) ! py
35707 C P(2,3) = PF*CT ! pz
35708 C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
35714 beta1=-p(2,1)/p(2,4)
35715 beta2=-p(2,2)/p(2,4)
35716 beta3=-p(2,3)/p(2,4)
35718 C WRITE(6,*)' before transforming into target rest frame'
35719 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35720 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35723 phi11=atan(p(1,2)/p(1,3))
35728 CALL DT_TESTROT(PI,Po,PHI11,1)
35730 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35736 phi12=atan(p(1,1)/p(1,3))
35741 CALL DT_TESTROT(Pi,Po,PHI12,2)
35743 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35752 C...Kinematical limits in Q**2
35753 c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
35754 S = P(2,5)**2 + 2.*ENU*P(2,5)
35755 SQS = SQRT(S) ! E centro massa
35756 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35757 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
35758 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
35759 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
35760 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
35761 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
35762 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
35765 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35766 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35767 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35768 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35769 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35771 C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35772 C &Q2,Q2min,Q2MAX,DSIGEV
35774 C...c.m. frame. Neutrino along z axis
35775 DETOT = (P(1,4)) + (P(2,4)) ! e totale
35776 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35777 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35778 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35781 C WRITE(*,*) 'Input values laboratory frame'
35784 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35787 c STHETA = ULANGL(P(1,3),P(1,1))
35788 c write(*,*) 'stheta' ,stheta
35790 c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35793 C WRITE(*,*) 'Output values cm frame'
35794 C...Kinematic in c.m. frame
35795 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35796 STSTAR = SQRT(1.-CTSTAR**2)
35797 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35798 P(4,5) = AML ! massa leptone
35799 P(4,4) = ELF ! e leptone
35800 P(4,3) = PLF*CTSTAR ! px
35801 P(4,1) = PLF*STSTAR*COS(PHI) ! py
35802 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35804 P(5,5) = AMF ! barione
35805 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35806 P(5,3) = -P(4,3) ! px
35807 P(5,1) = -P(4,1) ! py
35808 P(5,2) = -P(4,2) ! pz
35811 P(3,1) = P(1,1)-P(4,1)
35812 P(3,2) = P(1,2)-P(4,2)
35813 P(3,3) = P(1,3)-P(4,3)
35814 P(3,4) = P(1,4)-P(4,4)
35816 C...Transform back to laboratory frame
35817 C WRITE(*,*) 'before going back to nucl rest frame'
35818 c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35821 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35823 C WRITE(*,*) 'Now back in nucl rest frame'
35824 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35826 c********************************************
35832 CALL DT_TESTROT(Pi,Po,PHI12,3)
35834 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35840 c********************************************
35846 CALL DT_TESTROT(Pi,Po,PHI11,4)
35848 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35855 c********************************************
35857 C WRITE(*,*) 'Now back in lab frame'
35859 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35862 C...test (on final momentum of nucleon) if Fermi-blocking
35864 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35866 IF (ENUCL.LT. EFMAX) THEN
35867 IF(INIPRI.LT.10)THEN
35869 C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35870 C...the interaction is not possible due to Pauli-Blocking and
35871 C...it must be resampled
35874 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35875 IF(INIPRI.LT.10)THEN
35877 C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35879 C Reject (J:R) here all these events
35880 C are otherwise rejected in dpmjet
35882 C...the interaction is possible, but the nucleon remains inside
35883 C...the nucleus. The nucleus is therefore left excited.
35884 C...We treat this case as a nucleon with 0 kinetic energy.
35890 ELSE IF (ENUCL.GE.ENWELL) THEN
35891 C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35892 C...the interaction is possible, the nucleon can exit the nucleus
35893 C...but the nuclear well depth must be subtracted. The nucleus could be
35894 C...left in an excited state.
35895 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35896 C P(5,4) = ENUCL-ENWELL + AMF
35897 Pnucl = SQRT(P(5,4)**2-AMF**2)
35898 C...The 3-momentum is scaled assuming that the direction remains
35900 P(5,1) = P(5,1) * Pnucl/Pstart
35901 P(5,2) = P(5,2) * Pnucl/Pstart
35902 P(5,3) = P(5,3) * Pnucl/Pstart
35903 C WRITE(6,*)' qel new P(5,4) ',P(5,4)
35906 DSIGSU=DSIGSU+DSIGEV
35916 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35918 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35922 C PRINT*,' FINE EVENTO '
35926 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
35929 *$ CREATE DT_MASS_INI.FOR
35931 C====================================================================
35933 C====================================================================
35935 *===mass_ini===========================================================*
35937 SUBROUTINE DT_MASS_INI
35938 C...Initialize the kinematics for the quasi-elastic cross section
35940 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35943 * particle masses used in qel neutrino scattering modules
35944 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35945 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35946 & EMPROTSQ,EMNEUTSQ,EMNSQ
35948 EML(1) = 0.51100D-03 ! e-
35949 EML(2) = EML(1) ! e+
35950 EML(3) = 0.105659D0 ! mu-
35951 EML(4) = EML(3) ! mu+
35952 EML(5) = 1.7777D0 ! tau-
35953 EML(6) = EML(5) ! tau+
35954 EMPROT = 0.93827231D0 ! p
35955 EMNEUT = 0.93956563D0 ! n
35956 EMPROTSQ = EMPROT**2
35957 EMNEUTSQ = EMNEUT**2
35958 EMN = (EMPROT + EMNEUT)/2.
35962 EMN1(J0+1) = EMNEUT
35963 EMN1(J0+2) = EMPROT
35964 EMN2(J0+1) = EMPROT
35965 EMN2(J0+2) = EMNEUT
35968 EMLSQ(J) = EML(J)**2
35969 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35974 *$ CREATE DT_DSQEL_Q2.FOR
35977 *===dsqel_q2===========================================================*
35979 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35981 C...differential cross section for Quasi-Elastic scattering
35982 C. nu + N -> l + N'
35983 C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
35985 C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
35986 C. ENU (GeV) = Neutrino energy
35987 C. Q2 (GeV**2) = (Transfer momentum)**2
35989 C. OUTPUT : DSQEL_Q2 = differential cross section :
35990 C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
35991 C------------------------------------------------------------------
35993 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35996 * particle masses used in qel neutrino scattering modules
35997 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35998 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35999 & EMPROTSQ,EMNEUTSQ,EMNSQ
36000 **sr - removed (not needed)
36001 C COMMON /CAXIAL/ FA0, AXIAL2
36005 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36006 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36007 DATA AXIAL2 /1.03D0/ ! to be checked
36011 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
36012 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
36013 X = Q2/(EMN*EMN) ! emn=massa barione
36015 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36016 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36017 FA = FA0/(1.D0 + Q2/AXIAL2)**2
36021 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
36022 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
36023 A2 = -RM * ((FV1 + FV2)**2 + FFA)
36024 AA = (XA+0.25D0*RM)*(A1 + A2)
36025 BB = -X*FA*(FV1 + FV2)
36026 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
36027 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36028 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
36029 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
36034 *$ CREATE DT_PREPOLA.FOR
36037 *===prepola============================================================*
36039 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36041 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36044 c By G. Battistoni and E. Scapparone (sept. 1997)
36046 c Albright & Jarlskog, Nucl Phys B84 (1975) 467
36049 PARAMETER (MAXLND=4000)
36050 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36051 COMMON /QNPOL/ POLARX(4),PMODUL
36052 * particle masses used in qel neutrino scattering modules
36053 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36054 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36055 & EMPROTSQ,EMNEUTSQ,EMNSQ
36056 * steering flags for qel neutrino scattering modules
36057 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36058 **sr - removed (not needed)
36059 C COMMON /CAXIAL/ FA0, AXIAL2
36060 C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36061 C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36063 REAL*8 POL(4,4),BB2(3)
36065 C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36066 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36067 **sr uncommented since common block CAXIAL is now commented
36068 DATA AXIAL2 /1.03D0/ ! to be checked
36078 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
36079 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
36080 X = Q2/(EMN*EMN) ! emn=massa barione
36082 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36083 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36084 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36088 FP=2.D0*FA*RMM/(MPI**2 + Q2)
36089 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
36090 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36091 A2 = -RM * ((FV1 + FV2)**2 + FFA)
36092 AA = (XA+0.25D+00*RM)*(A1 + A2)
36093 BB = -X*FA*(FV1 + FV2)
36094 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36095 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36097 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
36099 OMEGA3=2.D+00*FA*(FV1+FV2)
36100 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36103 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36104 WW1=2.D+00*OMEGA1*EMN**2
36105 WW2=2.D+00*OMEGA2*EMN**2
36106 WW3=2.D+00*OMEGA3*EMN**2
36107 WW4=2.D+00*OMEGA4*EMN**2
36108 WW5=2.D+00*OMEGA5*EMN**2
36111 BB2(I)=-P(4,I)/P(4,4)
36115 c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36117 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36118 * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
36121 c WRITE(*,*) 'Prepola: now in lepton rest frame'
36125 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36126 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36127 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36129 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36130 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
36132 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36135 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36141 PMODUL=PMODUL+POL(4,I)**2
36144 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36145 IF(NEUDEC.EQ.1) THEN
36146 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36148 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36150 c Tau has decayed in muon
36153 IF(NEUDEC.EQ.2) THEN
36154 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36156 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36158 c Tau has decayed in electron
36166 c fill common for muon(electron)
36174 IF(NEUDEC.EQ.1) THEN
36177 ELSEIF(NEUDEC.EQ.2) THEN
36181 ELSEIF(JTYP.EQ.6) THEN
36182 IF(NEUDEC.EQ.1) THEN
36184 ELSEIF(NEUDEC.EQ.2) THEN
36192 c fill common for tau_(anti)neutrino
36202 ELSEIF(JTYP.EQ.6) THEN
36209 c Fill common for muon(electron)_(anti)neutrino
36218 IF(NEUDEC.EQ.1) THEN
36220 ELSEIF(NEUDEC.EQ.2) THEN
36223 ELSEIF(JTYP.EQ.6) THEN
36224 IF(NEUDEC.EQ.1) THEN
36226 ELSEIF(NEUDEC.EQ.2) THEN
36237 c IF(PMODUL.GE.1.D+00) THEN
36238 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36239 c write(*,*) pmodul
36241 c POL(4,I)=POL(4,I)/PMODUL
36242 c POLARX(I)=POL(4,I)
36246 c PMODUL=PMODUL+POL(4,I)**2
36248 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36252 c WRITE(*,*) 'PMODUL = ',PMODUL
36256 c WRITE(*,*) 'prepola: Now back to nucl rest frame'
36257 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36259 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36260 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36261 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36271 *$ CREATE DT_TESTROT.FOR
36274 *===testrot============================================================*
36276 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36278 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36281 DIMENSION ROT(3,3),PI(3),PO(3)
36283 IF (MODE.EQ.1) THEN
36288 ROT(2,2) = COS(PHI)
36289 ROT(2,3) = -SIN(PHI)
36291 ROT(3,2) = SIN(PHI)
36292 ROT(3,3) = COS(PHI)
36293 ELSEIF (MODE.EQ.2) THEN
36297 ROT(2,1) = COS(PHI)
36299 ROT(2,3) = -SIN(PHI)
36300 ROT(3,1) = SIN(PHI)
36302 ROT(3,3) = COS(PHI)
36303 ELSEIF (MODE.EQ.3) THEN
36307 ROT(1,2) = COS(PHI)
36309 ROT(3,2) = -SIN(PHI)
36310 ROT(1,3) = SIN(PHI)
36312 ROT(3,3) = COS(PHI)
36313 ELSEIF (MODE.EQ.4) THEN
36318 ROT(2,2) = COS(PHI)
36319 ROT(3,2) = -SIN(PHI)
36321 ROT(2,3) = SIN(PHI)
36322 ROT(3,3) = COS(PHI)
36324 STOP ' TESTROT: mode not supported!'
36327 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36333 *$ CREATE DT_LEPDCYP.FOR
36336 *===lepdcyp============================================================*
36338 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36339 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36341 C-----------------------------------------------------------------
36343 C Author :- G. Battistoni 10-NOV-1995
36345 C=================================================================
36347 C Purpose : performs decay of polarized lepton in
36348 C its rest frame: a => b + l + anti-nu
36349 C (Example: mu- => nu-mu + e- + anti-nu-e)
36350 C Polarization is assumed along Z-axis
36352 C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36353 C OF NEGLIGIBLE MASS
36354 C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36357 C Method : modifies phase space distribution obtained
36358 C by routine EXPLOD using a rejection against the
36359 C matrix element for unpolarized lepton decay
36361 C Inputs : Mass of a : AMA
36364 C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36367 C Outputs : kinematic variables in the rest frame of decaying lepton
36368 C ETL,PXL,PYL,PZL 4-moment of l
36369 C ETB,PXB,PYB,PZB 4-moment of b
36370 C ETN,PXN,PYN,PZN 4-moment of anti-nu
36372 C============================================================
36376 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36379 PARAMETER ( LINP = 10 ,
36382 PARAMETER ( KALGNM = 2 )
36383 PARAMETER ( ANGLGB = 5.0D-16 )
36384 PARAMETER ( ANGLSQ = 2.5D-31 )
36385 PARAMETER ( AXCSSV = 0.2D+16 )
36386 PARAMETER ( ANDRFL = 1.0D-38 )
36387 PARAMETER ( AVRFLW = 1.0D+38 )
36388 PARAMETER ( AINFNT = 1.0D+30 )
36389 PARAMETER ( AZRZRZ = 1.0D-30 )
36390 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36391 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36392 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
36393 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
36394 PARAMETER ( CSNNRM = 2.0D-15 )
36395 PARAMETER ( DMXTRN = 1.0D+08 )
36396 PARAMETER ( ZERZER = 0.D+00 )
36397 PARAMETER ( ONEONE = 1.D+00 )
36398 PARAMETER ( TWOTWO = 2.D+00 )
36399 PARAMETER ( THRTHR = 3.D+00 )
36400 PARAMETER ( FOUFOU = 4.D+00 )
36401 PARAMETER ( FIVFIV = 5.D+00 )
36402 PARAMETER ( SIXSIX = 6.D+00 )
36403 PARAMETER ( SEVSEV = 7.D+00 )
36404 PARAMETER ( EIGEIG = 8.D+00 )
36405 PARAMETER ( ANINEN = 9.D+00 )
36406 PARAMETER ( TENTEN = 10.D+00 )
36407 PARAMETER ( HLFHLF = 0.5D+00 )
36408 PARAMETER ( ONETHI = ONEONE / THRTHR )
36409 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36410 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36411 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36412 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36413 PARAMETER ( CLIGHT = 2.99792458 D+10 )
36414 PARAMETER ( AVOGAD = 6.0221367 D+23 )
36415 PARAMETER ( AMELGR = 9.1093897 D-28 )
36416 PARAMETER ( PLCKBR = 1.05457266 D-27 )
36417 PARAMETER ( ELCCGS = 4.8032068 D-10 )
36418 PARAMETER ( ELCMKS = 1.60217733 D-19 )
36419 PARAMETER ( AMUGRM = 1.6605402 D-24 )
36420 PARAMETER ( AMMUMU = 0.113428913 D+00 )
36421 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36422 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36423 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36424 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36425 PARAMETER ( PLABRC = 0.197327053 D+00 )
36426 PARAMETER ( AMELCT = 0.51099906 D-03 )
36427 PARAMETER ( AMUGEV = 0.93149432 D+00 )
36428 PARAMETER ( AMMUON = 0.105658389 D+00 )
36429 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36430 PARAMETER ( GEVMEV = 1.0 D+03 )
36431 PARAMETER ( EMVGEV = 1.0 D-03 )
36432 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
36433 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36434 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36436 C variables for EXPLOD
36438 PARAMETER ( KPMX = 10 )
36439 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36440 & PZEXPL (KPMX), ETEXPL (KPMX)
36444 **sr - removed (not needed)
36445 C COMMON /GBATNU/ ELERAT,NTRY
36448 C Initializes test variables
36453 C Maximum value for matrix element
36455 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36456 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36457 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36458 C Inputs for EXPLOD
36459 C part. no. 1 is l (e- in mu- decay)
36460 C part. no. 2 is b (nu-mu in mu- decay)
36461 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36462 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36469 C phase space distribution
36474 CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36478 C Calculates matrix element:
36479 C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36480 C Here CTH is the cosine of the angle between anti-nu and Z axis
36482 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36484 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36485 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36486 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36487 ELEMAT = 16.D+00 * PROD1 * PROD2
36488 IF(ELEMAT.GT.ELEMAX) THEN
36489 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36493 C Here performs the rejection
36495 TEST = DT_RNDM(ETOTEX) * ELEMAX
36496 IF ( TEST .GT. ELEMAT ) GO TO 100
36498 C final assignment of variables
36500 ELERAT = ELEMAT/ELEMAX
36516 *$ CREATE DT_GEN_DELTA.FOR
36518 C==================================================================
36519 C. Generation of Delta resonance events
36520 C==================================================================
36522 *===gen_delta==========================================================*
36524 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36526 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36529 PARAMETER ( LINP = 10 ,
36532 C...Generate a Delta-production neutrino/antineutrino
36533 C. CC-interaction on a nucleon
36535 C. INPUT ENU (GeV) = Neutrino Energy
36536 C. LLEP = neutrino type
36537 C. LTARG = nucleon target type 1=p, 2=n.
36538 C. JINT = 1:CC, 2::NC
36540 C. OUTPUT PPL(4) 4-monentum of final lepton
36541 C----------------------------------------------------
36542 PARAMETER (MAXLND=4000)
36543 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36544 **sr - removed (not needed)
36545 C COMMON /CBAD/ LBAD, NBAD
36548 DIMENSION PI(3),PO(3)
36549 C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36550 DIMENSION AML0(6),AMN(2)
36551 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36552 DATA AMN /0.93827231, 0.93956563/
36553 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36555 c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36557 C...Final lepton mass
36558 IF (JINT.EQ.1) THEN
36565 C...Particle labels (LUND)
36573 IF (LTARG .EQ. 1) THEN
36581 IS = -1 + 2*LLEP - 4*K1
36582 LNU = 2 - LLEP + 2*K1
36586 IF (JINT .EQ. 1) THEN ! CC interactions
36590 IF (LTARG .EQ. 1) THEN
36596 IF (LTARG .EQ. 1) THEN
36603 K(3,2) = 23 ! NC (Z0) interactions
36605 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36606 * Delta0 for neutron (LTARG=2)
36607 C IF (LTARG .EQ. 1) THEN
36612 IF (LTARG .EQ. 1) THEN
36620 C...4-momentum initial lepton
36626 C...4-momentum initial nucleon
36627 P(2,5) = AMN(LTARG)
36638 beta1=-p(2,1)/p(2,4)
36639 beta2=-p(2,2)/p(2,4)
36640 beta3=-p(2,3)/p(2,4)
36643 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36645 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36647 phi11=atan(p(1,2)/p(1,3))
36652 CALL DT_TESTROT(PI,Po,PHI11,1)
36654 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36659 phi12=atan(p(1,1)/p(1,3))
36664 CALL DT_TESTROT(Pi,Po,PHI12,2)
36666 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36674 C...Generate the Mass of the Delta
36677 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36679 IF (NTRY .GT. 1000) THEN
36681 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36684 IF (AMD .LT. AMDMIN) GOTO 100
36685 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36686 IF (ENUU .LT. ET) GOTO 100
36688 C...Kinematical limits in Q**2
36689 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36691 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36692 ELF = (S - AMD**2 + AML2)/(2.*SQS)
36693 PLF = SQRT(ELF**2 - AML2)
36694 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36695 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36696 IF (Q2MIN .LT. 0.) Q2MIN = 0.
36698 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36699 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36700 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36701 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
36703 C...Generate the kinematics of the final particles
36704 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36705 GAM = EISTAR/AMN(LTARG)
36707 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36708 EL = GAM*(ELF + BET*PLF*CTSTAR)
36709 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36710 PL = SQRT(EL**2 - AML2)
36711 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36712 PHI = 6.28319*PYR(0)
36713 P(4,1) = PLT*COS(PHI)
36714 P(4,2) = PLT*SIN(PHI)
36719 C...4-momentum of Delta
36722 P(5,3) = ENUU-P(4,3)
36723 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36726 C...4-momentum of intermediate boson
36728 P(3,4) = P(1,4)-P(4,4)
36729 P(3,1) = P(1,1)-P(4,1)
36730 P(3,2) = P(1,2)-P(4,2)
36731 P(3,3) = P(1,3)-P(4,3)
36738 CALL DT_TESTROT(Pi,Po,PHI12,3)
36740 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36747 c********************************************
36753 CALL DT_TESTROT(Pi,Po,PHI11,4)
36755 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36761 c********************************************
36762 C transform back into Lab.
36764 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36766 C WRITE(6,*)' Lab fram ( fermi incl.) '
36771 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
36774 *$ CREATE DT_DSIGMA_DELTA.FOR
36775 *COPY DT_DSIGMA_DELTA
36777 *===dsigma_delta=======================================================*
36779 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36781 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36784 C...Reaction nu + N -> lepton + Delta
36785 C. returns the cross section
36787 C. INPUT LNU = 1, 2 (neutrino-antineutrino)
36788 C. QQ = t (always negative) GeV**2
36789 C. S = (c.m energy)**2 GeV**2
36790 C. OUTPUT = 10**-38 cm+2/GeV**2
36791 C-----------------------------------------------------
36792 REAL*8 MN, MN2, MN4, MD,MD2, MD4
36794 DATA PI /3.1415926/
36796 GF = (1.1664 * 1.97)
36804 VQ = (MN2 - MD2 - QQ)/2.
36805 VPI = (MN2 + MD2 - QQ)/2.
36806 VK = (S + QQ - MN2 - AML2)/2.
36808 QK = (AML2 - QQ)/2.
36809 PIQ = (QQ + MN2 - MD2)/2.
36811 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36812 C3 = SQRT(3.)*C3V/MN
36813 C4 = -C3/MD ! attenzione al segno
36814 C5A = 1.18/(1.-QQ/0.4225)**2
36819 IF (LNU .EQ. 1) THEN
36820 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36821 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36822 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36823 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36824 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36825 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36826 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36827 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36828 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36829 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36830 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36831 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36832 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36833 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36834 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36835 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36836 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36837 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36838 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36839 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36840 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36841 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36842 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36844 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36845 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36846 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36847 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36848 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36849 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36850 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36851 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36852 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36853 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36854 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36855 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36856 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36857 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36858 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36859 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36860 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36861 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36862 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36863 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36864 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36865 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36866 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36870 P1CM = (S-MN2)/(2.*SQRT(S))
36871 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36876 *$ CREATE DT_QGAUS.FOR
36879 *===qgaus==============================================================*
36881 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36883 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36886 DIMENSION X(5),W(5)
36887 DATA X/.1488743389D0,.4333953941D0,
36888 & .6794095682D0,.8650633666D0,.9739065285D0
36890 DATA W/.2955242247D0,.2692667193D0,
36891 & .2190863625D0,.1494513491D0,.0666713443D0
36898 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36899 * DT_DSQEL_Q2(LTYP,ENU,XM-DX))
36906 *$ CREATE DT_DIQBRK.FOR
36909 *===diqbrk=============================================================*
36911 SUBROUTINE DT_DIQBRK
36913 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36917 PARAMETER (NMXHKK=200000)
36918 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36919 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36920 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36921 * extended event history
36922 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36923 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36926 COMMON /DTEVNO/ NEVENT,ICASCA
36928 C IF(DT_RNDM(VV).LE.0.5D0)THEN
36929 C CALL GSQBS1(NHKK)
36930 C CALL GSQBS2(NHKK)
36931 C CALL USQBS1(NHKK)
36932 C CALL USQBS2(NHKK)
36933 C CALL GSABS1(NHKK)
36934 C CALL GSABS2(NHKK)
36935 C CALL USABS1(NHKK)
36936 C CALL USABS2(NHKK)
36938 C CALL GSQBS2(NHKK)
36939 C CALL GSQBS1(NHKK)
36940 C CALL USQBS2(NHKK)
36941 C CALL USQBS1(NHKK)
36942 C CALL GSABS2(NHKK)
36943 C CALL GSABS1(NHKK)
36944 C CALL USABS2(NHKK)
36945 C CALL USABS1(NHKK)
36948 IF(DT_RNDM(VV).LE.0.5D0) THEN
36971 *$ CREATE MUSQBS2.FOR
36975 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36976 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36977 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36979 C USQBS-2 diagram (split target diquark)
36981 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36984 PARAMETER ( LINP = 10 ,
36988 PARAMETER (NMXHKK=200000)
36989 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36990 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36991 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36992 * extended event history
36993 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36994 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36996 * Lorentz-parameters of the current interaction
36997 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36998 & UMO,PPCM,EPROJ,PPROJ
36999 * diquark-breaking mechanism
37000 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37003 PARAMETER (NTMHKK= 300)
37004 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37005 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37008 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37011 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37012 COMMON /EVFLAG/ NUMEV
37014 C USQBS-2 diagram (split target diquark)
37017 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37018 C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
37020 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37021 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37023 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37024 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37025 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37028 C Put new chains into COMMON /HKKTMP/
37033 C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37037 C IF(NUMEV.EQ.-324)THEN
37038 C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37039 C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37040 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37041 C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37046 C determine x-values of NC1T diquark
37047 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37048 XVQP=PHKK(4,NC1P)*2.D0/UMO
37050 C determine x-values of sea quark pair
37056 IF(ICOU.GE.500)THEN
37059 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37063 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37068 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37069 IF (IPIP.EQ.1) THEN
37070 XQMAX = XDIQT/2.0D0
37071 XAQMAX = 2.D0*XVQP/3.0D0
37073 XQMAX = 2.D0*XVQP/3.0D0
37074 XAQMAX = XDIQT/2.0D0
37076 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37078 C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37081 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37084 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37089 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37090 ELSEIF(IPIP.EQ.2)THEN
37091 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37094 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37095 * XDIQT,XVQP,XSQ,XSAQ
37098 C subtract xsq,xsaq from NC1T diquark and NC1P quark
37104 ELSEIF(IPIP.EQ.2)THEN
37109 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37111 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37116 IF(IVTHR.EQ.10)THEN
37119 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37124 XVTHR=XVTHRO/(201-IVTHR)
37127 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37130 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ',
37135 IF(DT_RNDM(V).LT.0.5D0)THEN
37136 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37139 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37143 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37146 C Prepare 4 momenta of new chains and chain ends
37148 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37149 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37152 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37153 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37154 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37156 C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37157 C * IP1,IP21,IP22,IPP1,IPP2)
37164 ELSEIF(IPIP.EQ.2)THEN
37174 JDAHKT(1,1)=3+IIGLU1
37176 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37177 PHKT(1,1) =PHKK(1,NC2P)
37178 PHKT(2,1) =PHKK(2,NC2P)
37179 PHKT(3,1) =PHKK(3,NC2P)
37180 PHKT(4,1) =PHKK(4,NC2P)
37181 C PHKT(5,1) =PHKK(5,NC2P)
37182 XMIST =(PHKT(4,1)**2-
37183 * PHKT(3,1)**2-PHKT(2,1)**2-
37185 IF(XMIST.GT.0.D0)THEN
37186 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37189 C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37192 VHKT(1,1) =VHKK(1,NC2P)
37193 VHKT(2,1) =VHKK(2,NC2P)
37194 VHKT(3,1) =VHKK(3,NC2P)
37195 VHKT(4,1) =VHKK(4,NC2P)
37196 WHKT(1,1) =WHKK(1,NC2P)
37197 WHKT(2,1) =WHKK(2,NC2P)
37198 WHKT(3,1) =WHKK(3,NC2P)
37199 WHKT(4,1) =WHKK(4,NC2P)
37200 C Add here IIGLU1 gluons to this chaina
37205 IF(IIGLU1.GE.1)THEN
37207 DO 61 IIG=2,2+IIGLU1-1
37209 IDHKT(IIG) =IDHKK(KKG)
37213 JDAHKT(1,IIG)=3+IIGLU1
37215 PHKT(1,IIG)=PHKK(1,KKG)
37216 PG1=PG1+ PHKT(1,IIG)
37217 PHKT(2,IIG)=PHKK(2,KKG)
37218 PG2=PG2+ PHKT(2,IIG)
37219 PHKT(3,IIG)=PHKK(3,KKG)
37220 PG3=PG3+ PHKT(3,IIG)
37221 PHKT(4,IIG)=PHKK(4,KKG)
37222 PG4=PG4+ PHKT(4,IIG)
37223 PHKT(5,IIG)=PHKK(5,KKG)
37224 VHKT(1,IIG) =VHKK(1,KKG)
37225 VHKT(2,IIG) =VHKK(2,KKG)
37226 VHKT(3,IIG) =VHKK(3,KKG)
37227 VHKT(4,IIG) =VHKK(4,KKG)
37228 WHKT(1,IIG) =WHKK(1,KKG)
37229 WHKT(2,IIG) =WHKK(2,KKG)
37230 WHKT(3,IIG) =WHKK(3,KKG)
37231 WHKT(4,IIG) =WHKK(4,KKG)
37234 IDHKT(2+IIGLU1) =IP21
37235 ISTHKT(2+IIGLU1) =952
37236 JMOHKT(1,2+IIGLU1)=NC1T
37237 JMOHKT(2,2+IIGLU1)=0
37238 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37239 JDAHKT(2,2+IIGLU1)=0
37240 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37241 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37242 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37243 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37244 C PHKT(5,2) =PHKK(5,NC1T)
37245 XMIST =(PHKT(4,2+IIGLU1)**2-
37246 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37247 *PHKT(1,2+IIGLU1)**2)
37248 IF(XMIST.GT.0.D0)THEN
37249 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37250 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37251 *PHKT(1,2+IIGLU1)**2)
37253 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37254 PHKT(5,5+IIGLU1)=0.D0
37256 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
37257 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
37258 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
37259 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
37260 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
37261 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
37262 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
37263 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
37264 IDHKT(3+IIGLU1) =88888
37265 ISTHKT(3+IIGLU1) =95
37266 JMOHKT(1,3+IIGLU1)=1
37267 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37268 JDAHKT(1,3+IIGLU1)=0
37269 JDAHKT(2,3+IIGLU1)=0
37270 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37271 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37272 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37273 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37275 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37276 * -PHKT(3,3+IIGLU1)**2)
37277 IF(XMIST.GT.0.D0)THEN
37279 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37280 * -PHKT(3,3+IIGLU1)**2)
37282 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37283 PHKT(5,5+IIGLU1)=0.D0
37286 C IF(NUMEV.EQ.-324)THEN
37287 C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37289 C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37290 DO 71 IIG=2,2+IIGLU1-1
37291 C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37292 C & JMOHKT(1,IIG),JMOHKT(2,IIG),
37294 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37296 C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37297 C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37298 C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37299 C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37300 C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37301 C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37305 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37306 ELSEIF(IPIP.EQ.2)THEN
37307 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37309 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37313 C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37316 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37317 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37318 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37319 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37320 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37321 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37322 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37323 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37325 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37326 ELSEIF(IPIP.EQ.2)THEN
37327 IDHKT(4+IIGLU1) =ISAQ1
37329 ISTHKT(4+IIGLU1) =951
37330 JMOHKT(1,4+IIGLU1)=NC1P
37331 JMOHKT(2,4+IIGLU1)=0
37332 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37333 JDAHKT(2,4+IIGLU1)=0
37334 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37335 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37336 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37337 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37338 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37339 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37340 XMIST =(PHKT(4,4+IIGLU1)**2-
37341 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37342 *PHKT(1,4+IIGLU1)**2)
37343 IF(XMIST.GT.0.D0)THEN
37344 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37345 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37346 *PHKT(1,4+IIGLU1)**2)
37348 C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37349 PHKT(5,4+IIGLU1)=0.D0
37351 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37352 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37353 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37354 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37355 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37356 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37357 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37358 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37359 IDHKT(5+IIGLU1) =IP22
37360 ISTHKT(5+IIGLU1) =952
37361 JMOHKT(1,5+IIGLU1)=NC1T
37362 JMOHKT(2,5+IIGLU1)=0
37363 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37364 JDAHKT(2,5+IIGLU1)=0
37365 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37366 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37367 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37368 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37369 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37370 XMIST =(PHKT(4,5+IIGLU1)**2-
37371 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37372 *PHKT(1,5+IIGLU1)**2)
37373 IF(XMIST.GT.0.D0)THEN
37374 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37375 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37376 *PHKT(1,5+IIGLU1)**2)
37378 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37379 PHKT(5,5+IIGLU1)=0.D0
37381 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37382 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37383 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37384 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37385 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37386 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37387 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37388 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37389 IDHKT(6+IIGLU1) =88888
37390 ISTHKT(6+IIGLU1) =95
37391 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37392 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37393 JDAHKT(1,6+IIGLU1)=0
37394 JDAHKT(2,6+IIGLU1)=0
37395 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37396 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37397 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37398 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37400 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37401 * -PHKT(3,6+IIGLU1)**2)
37402 IF(XMIST.GT.0.D0)THEN
37404 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37405 * -PHKT(3,6+IIGLU1)**2)
37407 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37408 PHKT(5,5+IIGLU1)=0.D0
37410 C IF(IPIP.GE.2)THEN
37411 C IF(NUMEV.EQ.-324)THEN
37412 C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37413 C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37414 C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37415 C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37416 C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37417 C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37418 C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37419 C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37420 C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37424 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37425 ELSEIF(IPIP.EQ.2)THEN
37426 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37428 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37432 C WRITE(6,*)' MUSQBS1 jump back from chain 6',
37433 C * CHAMAL,PHKT(5,6+IIGLU1)
37436 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37437 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37438 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37439 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37440 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37441 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37442 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37443 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37444 C IDHKT(7) =1000*IPP1+100*ISQ+1
37445 IDHKT(7+IIGLU1) =IP1
37446 ISTHKT(7+IIGLU1) =951
37447 JMOHKT(1,7+IIGLU1)=NC1P
37448 JMOHKT(2,7+IIGLU1)=0
37450 C JDAHKT(1,7+IIGLU1)=9+IIGLU1
37451 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37453 JDAHKT(2,7+IIGLU1)=0
37454 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37455 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37456 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37457 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37458 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
37459 XMIST =(PHKT(4,7+IIGLU1)**2-
37460 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37461 *PHKT(1,7+IIGLU1)**2)
37462 IF(XMIST.GT.0.D0)THEN
37463 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37464 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37465 *PHKT(1,7+IIGLU1)**2)
37467 C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37468 PHKT(5,7+IIGLU1)=0.D0
37470 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
37471 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
37472 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
37473 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
37474 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
37475 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
37476 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
37477 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37478 C Insert here the IIGLU2 gluons
37483 IF(IIGLU2.GE.1)THEN
37485 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37486 KKG=JJG+IIG-7-IIGLU1
37487 IDHKT(IIG) =IDHKK(KKG)
37491 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37493 PHKT(1,IIG)=PHKK(1,KKG)
37494 PG1=PG1+ PHKT(1,IIG)
37495 PHKT(2,IIG)=PHKK(2,KKG)
37496 PG2=PG2+ PHKT(2,IIG)
37497 PHKT(3,IIG)=PHKK(3,KKG)
37498 PG3=PG3+ PHKT(3,IIG)
37499 PHKT(4,IIG)=PHKK(4,KKG)
37500 PG4=PG4+ PHKT(4,IIG)
37501 PHKT(5,IIG)=PHKK(5,KKG)
37502 VHKT(1,IIG) =VHKK(1,KKG)
37503 VHKT(2,IIG) =VHKK(2,KKG)
37504 VHKT(3,IIG) =VHKK(3,KKG)
37505 VHKT(4,IIG) =VHKK(4,KKG)
37506 WHKT(1,IIG) =WHKK(1,KKG)
37507 WHKT(2,IIG) =WHKK(2,KKG)
37508 WHKT(3,IIG) =WHKK(3,KKG)
37509 WHKT(4,IIG) =WHKK(4,KKG)
37513 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
37514 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37515 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37516 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37517 ELSEIF(IPIP.EQ.2)THEN
37518 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
37519 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37520 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37521 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37523 ISTHKT(8+IIGLU1+IIGLU2) =952
37524 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37525 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37526 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37527 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37528 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
37529 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37530 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
37531 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37532 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
37533 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37534 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
37535 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37536 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37537 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37538 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37540 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37541 C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37546 C PHKT(5,8) =PHKK(5,NC2T)
37547 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37548 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37549 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37550 IF(XMIST.GT.0.D0)THEN
37551 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37552 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37553 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37555 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37556 PHKT(5,5+IIGLU1)=0.D0
37558 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
37559 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
37560 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
37561 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
37562 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
37563 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
37564 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
37565 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
37566 IDHKT(9+IIGLU1+IIGLU2) =88888
37567 ISTHKT(9+IIGLU1+IIGLU2) =95
37568 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37569 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37570 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37571 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37573 C PHKT(1,9+IIGLU1+IIGLU2)
37574 C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37575 C PHKT(2,9+IIGLU1+IIGLU2)
37576 C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37577 C PHKT(3,9+IIGLU1+IIGLU2)
37578 C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37579 C PHKT(4,9+IIGLU1+IIGLU2)
37580 C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37581 PHKT(1,9+IIGLU1+IIGLU2)
37582 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37583 PHKT(2,9+IIGLU1+IIGLU2)
37584 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37585 PHKT(3,9+IIGLU1+IIGLU2)
37586 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37587 PHKT(4,9+IIGLU1+IIGLU2)
37588 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37591 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37592 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37593 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37594 IF(XMIST.GT.0.D0)THEN
37595 PHKT(5,9+IIGLU1+IIGLU2)
37596 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37597 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37598 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37600 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37601 PHKT(5,5+IIGLU1)=0.D0
37604 C IF(NUMEV.EQ.-324)THEN
37605 C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37606 C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37607 C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37608 C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37609 C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37611 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37613 C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37614 C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37615 C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37616 C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37617 C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37618 C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37619 C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37620 C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37624 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37625 ELSEIF(IPIP.EQ.2)THEN
37626 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37628 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37632 C WRITE(6,*)' MUSQBS1 jump back from chain 9',
37633 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37636 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37637 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37638 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37639 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37640 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37641 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37642 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37643 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37646 IGCOUN=9+IIGLU1+IIGLU2
37650 *$ CREATE MGSQBS2.FOR
37654 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37655 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37656 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37658 C GSQBS-2 diagram (split target diquark)
37660 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37663 PARAMETER ( LINP = 10 ,
37667 PARAMETER (NMXHKK=200000)
37668 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37669 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37670 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37671 * extended event history
37672 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37673 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37675 * Lorentz-parameters of the current interaction
37676 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37677 & UMO,PPCM,EPROJ,PPROJ
37678 * diquark-breaking mechanism
37679 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37682 PARAMETER (NTMHKK= 300)
37683 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37684 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37688 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37691 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37693 C GSQBS-2 diagram (split target diquark)
37696 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37697 C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37699 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37700 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37702 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37703 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37704 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37708 C Put new chains into COMMON /HKKTMP/
37713 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37716 C IF(IPIP.EQ.2)THEN
37717 C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37718 C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37719 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37720 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37725 C determine x-values of NC1T diquark
37726 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37727 XVQP=PHKK(4,NC1P)*2.D0/UMO
37729 C determine x-values of sea quark pair
37735 IF(ICOU.GE.500)THEN
37739 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37744 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37749 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37750 IF (IPIP.EQ.1) THEN
37751 XQMAX = XDIQT/2.0D0
37752 XAQMAX = 2.D0*XVQP/3.0D0
37754 XQMAX = 2.D0*XVQP/3.0D0
37755 XAQMAX = XDIQT/2.0D0
37757 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37759 C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37762 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37765 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37770 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37771 ELSEIF(IPIP.EQ.2)THEN
37772 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37775 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37776 * XDIQT,XVQP,XSQ,XSAQ
37779 C subtract xsq,xsaq from NC1T diquark and NC1P quark
37785 ELSEIF(IPIP.EQ.2)THEN
37790 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37792 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37797 IF(IVTHR.EQ.10)THEN
37800 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37805 XVTHR=XVTHRO/(201-IVTHR)
37808 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37811 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ',
37816 IF(DT_RNDM(V).LT.0.5D0)THEN
37817 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37820 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37824 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37827 C Prepare 4 momenta of new chains and chain ends
37829 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37830 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37833 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37834 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37835 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37837 C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37838 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37845 ELSEIF(IPIP.EQ.2)THEN
37852 C IDHKT(1) =1000*IPP11+100*IPP12+1
37857 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37858 ELSEIF(IPIP.EQ.2)THEN
37859 IDHKT(4+IIGLU1) =ISAQ1
37861 ISTHKT(4+IIGLU1) =961
37862 JMOHKT(1,4+IIGLU1)=NC1P
37863 JMOHKT(2,4+IIGLU1)=0
37864 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37865 JDAHKT(2,4+IIGLU1)=0
37866 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37867 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37868 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37869 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37870 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37871 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37872 XXMIST=(PHKT(4,4+IIGLU1)**2-
37873 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37874 *PHKT(1,4+IIGLU1)**2)
37875 IF(XXMIST.GT.0.D0)THEN
37876 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37878 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37880 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37882 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37883 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37884 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37885 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37886 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37887 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37888 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37889 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37890 IDHKT(5+IIGLU1) =IP22
37891 ISTHKT(5+IIGLU1) =962
37892 JMOHKT(1,5+IIGLU1)=NC1T
37893 JMOHKT(2,5+IIGLU1)=0
37894 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37895 JDAHKT(2,5+IIGLU1)=0
37896 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37897 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37898 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37899 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37900 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37901 XXMIST=(PHKT(4,5+IIGLU1)**2-
37902 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37903 *PHKT(1,5+IIGLU1)**2)
37904 IF(XXMIST.GT.0.D0)THEN
37905 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37907 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37909 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37911 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37912 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37913 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37914 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37915 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37916 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37917 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37918 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37919 IDHKT(6+IIGLU1) =88888
37920 ISTHKT(6+IIGLU1) =96
37921 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37922 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37923 JDAHKT(1,6+IIGLU1)=0
37924 JDAHKT(2,6+IIGLU1)=0
37925 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37926 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37927 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37928 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37930 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37931 * -PHKT(3,6+IIGLU1)**2)
37934 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37935 ELSEIF(IPIP.EQ.2)THEN
37936 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37938 C---------------------------------------------------
37939 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37940 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37941 C we drop chain 6 and give the energy to chain 3
37942 IDHKT(6+IIGLU1)=22888
37944 C WRITE(6,*)' drop chain 6 xgive=1'
37946 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37947 C we drop chain 6 and give the energy to chain 3
37948 C and change KK11 to IDHKT(5)
37949 IDHKT(6+IIGLU1)=22888
37951 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37952 KK11=IDHKT(5+IIGLU1)
37954 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37955 C we drop chain 6 and give the energy to chain 3
37956 C and change KK21 to IDHKT(5+IIGLU1)
37957 C IDHKT(1) =1000*IPP11+100*IPP12+1
37958 IDHKT(6+IIGLU1)=22888
37960 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37961 KK21=IDHKT(5+IIGLU1)
37963 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37964 C we drop chain 6 and give the energy to chain 3
37965 C and change KK22 to IDHKT(5)
37966 C IDHKT(1) =1000*IPP11+100*IPP12+1
37967 IDHKT(6+IIGLU1)=22888
37969 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37970 KK22=IDHKT(5+IIGLU1)
37979 C---------------------------------------------------
37981 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37982 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37983 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37984 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37985 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37986 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37987 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37988 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37989 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37991 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37992 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37993 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37994 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37995 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37996 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37997 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37998 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37999 C IDHKT(1) =1000*IPP11+100*IPP12+1
38001 IDHKT(1) =1000*KK21+100*KK22+3
38002 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
38003 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
38004 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
38005 ELSEIF(IPIP.EQ.2)THEN
38006 IDHKT(1) =1000*KK21+100*KK22-3
38007 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
38008 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
38009 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
38014 JDAHKT(1,1)=3+IIGLU1
38016 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
38017 PHKT(1,1) =PHKK(1,NC2P)
38018 *+XGIVE*PHKT(1,4+IIGLU1)
38019 PHKT(2,1) =PHKK(2,NC2P)
38020 *+XGIVE*PHKT(2,4+IIGLU1)
38021 PHKT(3,1) =PHKK(3,NC2P)
38022 *+XGIVE*PHKT(3,4+IIGLU1)
38023 PHKT(4,1) =PHKK(4,NC2P)
38024 *+XGIVE*PHKT(4,4+IIGLU1)
38025 C PHKT(5,1) =PHKK(5,NC2P)
38026 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38028 IF(XXMIST.GT.0.D0)THEN
38029 PHKT(5,1) =SQRT(XXMIST)
38031 WRITE(LOUT,*)'MGSQBS2',XXMIST
38033 PHKT(5,1) =SQRT(XXMIST)
38035 VHKT(1,1) =VHKK(1,NC2P)
38036 VHKT(2,1) =VHKK(2,NC2P)
38037 VHKT(3,1) =VHKK(3,NC2P)
38038 VHKT(4,1) =VHKK(4,NC2P)
38039 WHKT(1,1) =WHKK(1,NC2P)
38040 WHKT(2,1) =WHKK(2,NC2P)
38041 WHKT(3,1) =WHKK(3,NC2P)
38042 WHKT(4,1) =WHKK(4,NC2P)
38043 C Add here IIGLU1 gluons to this chaina
38048 IF(IIGLU1.GE.1)THEN
38050 DO 61 IIG=2,2+IIGLU1-1
38052 IDHKT(IIG) =IDHKK(KKG)
38056 JDAHKT(1,IIG)=3+IIGLU1
38058 PHKT(1,IIG)=PHKK(1,KKG)
38059 PG1=PG1+ PHKT(1,IIG)
38060 PHKT(2,IIG)=PHKK(2,KKG)
38061 PG2=PG2+ PHKT(2,IIG)
38062 PHKT(3,IIG)=PHKK(3,KKG)
38063 PG3=PG3+ PHKT(3,IIG)
38064 PHKT(4,IIG)=PHKK(4,KKG)
38065 PG4=PG4+ PHKT(4,IIG)
38066 PHKT(5,IIG)=PHKK(5,KKG)
38067 VHKT(1,IIG) =VHKK(1,KKG)
38068 VHKT(2,IIG) =VHKK(2,KKG)
38069 VHKT(3,IIG) =VHKK(3,KKG)
38070 VHKT(4,IIG) =VHKK(4,KKG)
38071 WHKT(1,IIG) =WHKK(1,KKG)
38072 WHKT(2,IIG) =WHKK(2,KKG)
38073 WHKT(3,IIG) =WHKK(3,KKG)
38074 WHKT(4,IIG) =WHKK(4,KKG)
38078 IDHKT(2+IIGLU1) =KK11
38079 ISTHKT(2+IIGLU1) =962
38080 JMOHKT(1,2+IIGLU1)=NC1T
38081 JMOHKT(2,2+IIGLU1)=0
38082 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38083 JDAHKT(2,2+IIGLU1)=0
38084 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38085 C * +0.5D0*PHKK(1,NC2T)
38086 *+XGIVE*PHKT(1,5+IIGLU1)
38087 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38088 C *+0.5D0*PHKK(2,NC2T)
38089 *+XGIVE*PHKT(2,5+IIGLU1)
38090 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38091 C *+0.5D0*PHKK(3,NC2T)
38092 *+XGIVE*PHKT(3,5+IIGLU1)
38093 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38094 C *+0.5D0*PHKK(4,NC2T)
38095 *+XGIVE*PHKT(4,5+IIGLU1)
38096 C PHKT(5,2) =PHKK(5,NC1T)
38097 XXMIST=(PHKT(4,2+IIGLU1)**2-
38098 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38099 *PHKT(1,2+IIGLU1)**2)
38100 IF(XXMIST.GT.0.D0)THEN
38101 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38103 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38105 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38107 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
38108 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
38109 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
38110 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
38111 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
38112 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
38113 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
38114 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
38115 IDHKT(3+IIGLU1) =88888
38116 ISTHKT(3+IIGLU1) =96
38117 JMOHKT(1,3+IIGLU1)=1
38118 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38119 JDAHKT(1,3+IIGLU1)=0
38120 JDAHKT(2,3+IIGLU1)=0
38121 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38122 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38123 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38124 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38126 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38127 * -PHKT(3,3+IIGLU1)**2)
38129 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38131 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38132 DO 71 IIG=2,2+IIGLU1-1
38133 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38134 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38136 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38138 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38139 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38140 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38141 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38142 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38143 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38147 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38148 ELSEIF(IPIP.EQ.2)THEN
38149 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38151 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38157 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38158 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38159 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38160 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38161 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38162 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38163 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38164 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38165 C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
38166 IDHKT(7+IIGLU1) =IP1
38167 ISTHKT(7+IIGLU1) =961
38168 JMOHKT(1,7+IIGLU1)=NC1P
38169 JMOHKT(2,7+IIGLU1)=0
38170 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38171 JDAHKT(2,7+IIGLU1)=0
38172 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38173 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38174 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38175 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38176 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
38177 XXMIST=(PHKT(4,7+IIGLU1)**2-
38178 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38179 *PHKT(1,7+IIGLU1)**2)
38180 IF(XXMIST.GT.0.D0)THEN
38181 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38183 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38185 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38187 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
38188 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
38189 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
38190 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
38191 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
38192 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
38193 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
38194 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38195 C IDHKT(7) =1000*IPP1+100*ISQ+1
38196 C Insert here the IIGLU2 gluons
38201 IF(IIGLU2.GE.1)THEN
38203 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38204 KKG=JJG+IIG-7-IIGLU1
38205 IDHKT(IIG) =IDHKK(KKG)
38209 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38211 PHKT(1,IIG)=PHKK(1,KKG)
38212 PG1=PG1+ PHKT(1,IIG)
38213 PHKT(2,IIG)=PHKK(2,KKG)
38214 PG2=PG2+ PHKT(2,IIG)
38215 PHKT(3,IIG)=PHKK(3,KKG)
38216 PG3=PG3+ PHKT(3,IIG)
38217 PHKT(4,IIG)=PHKK(4,KKG)
38218 PG4=PG4+ PHKT(4,IIG)
38219 PHKT(5,IIG)=PHKK(5,KKG)
38220 VHKT(1,IIG) =VHKK(1,KKG)
38221 VHKT(2,IIG) =VHKK(2,KKG)
38222 VHKT(3,IIG) =VHKK(3,KKG)
38223 VHKT(4,IIG) =VHKK(4,KKG)
38224 WHKT(1,IIG) =WHKK(1,KKG)
38225 WHKT(2,IIG) =WHKK(2,KKG)
38226 WHKT(3,IIG) =WHKK(3,KKG)
38227 WHKT(4,IIG) =WHKK(4,KKG)
38231 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
38232 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38233 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38234 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38235 ELSEIF(IPIP.EQ.2)THEN
38237 C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
38238 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
38240 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38241 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38242 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38244 ISTHKT(8+IIGLU1+IIGLU2) =962
38245 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38246 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38247 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38248 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38249 C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38250 C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38251 C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38252 C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38253 PHKT(1,8+IIGLU1+IIGLU2) =
38254 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38255 PHKT(2,8+IIGLU1+IIGLU2) =
38256 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38257 PHKT(3,8+IIGLU1+IIGLU2) =
38258 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38259 PHKT(4,8+IIGLU1+IIGLU2) =
38260 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38261 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38262 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38263 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38265 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38270 C PHKT(5,8) =PHKK(5,NC2T)
38271 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38272 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38273 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38274 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
38275 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
38276 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
38277 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
38278 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
38279 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
38280 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
38281 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
38282 IDHKT(9+IIGLU1+IIGLU2) =88888
38283 ISTHKT(9+IIGLU1+IIGLU2) =96
38284 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38285 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38286 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38287 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38288 PHKT(1,9+IIGLU1+IIGLU2)
38289 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38290 PHKT(2,9+IIGLU1+IIGLU2)
38291 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38292 PHKT(3,9+IIGLU1+IIGLU2)
38293 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38294 PHKT(4,9+IIGLU1+IIGLU2)
38295 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38296 PHKT(5,9+IIGLU1+IIGLU2)
38297 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38298 * PHKT(2,9+IIGLU1+IIGLU2)**2
38299 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38301 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38302 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38303 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38304 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38305 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38306 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38308 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38310 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38311 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38312 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38313 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38314 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38315 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38316 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38317 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38321 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38322 ELSEIF(IPIP.EQ.2)THEN
38323 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38325 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38331 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38332 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38333 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38334 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38335 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38336 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38337 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38338 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38341 IGCOUN=9+IIGLU1+IIGLU2
38345 *$ CREATE MUSQBS1.FOR
38349 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38350 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38351 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38353 C USQBS-1 diagram (split projectile diquark)
38355 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38358 PARAMETER ( LINP = 10 ,
38362 PARAMETER (NMXHKK=200000)
38363 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38364 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38365 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38366 * extended event history
38367 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38368 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38370 * Lorentz-parameters of the current interaction
38371 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38372 & UMO,PPCM,EPROJ,PPROJ
38373 * diquark-breaking mechanism
38374 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38377 PARAMETER (NTMHKK= 300)
38378 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38379 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38382 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38385 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38386 COMMON /EVFLAG/ NUMEV
38388 C USQBS-1 diagram (split projectile diquark)
38390 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38391 C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38393 C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38394 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38396 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38397 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38398 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38400 C Put new chains into COMMON /HKKTMP/
38405 C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38409 C IF(NUMEV.EQ.-324)THEN
38410 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38411 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38412 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38413 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38418 C determine x-values of NC1P diquark
38419 XDIQP=PHKK(4,NC1P)*2.D0/UMO
38420 XVQT=PHKK(4,NC1T)*2.D0/UMO
38422 C determine x-values of sea quark pair
38428 IF(ICOU.GE.500)THEN
38431 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38435 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
38440 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38441 IF (IPIP.EQ.1) THEN
38442 XQMAX = XDIQP/2.0D0
38443 XAQMAX = 2.D0*XVQT/3.0D0
38445 XQMAX = 2.D0*XVQT/3.0D0
38446 XAQMAX = XDIQP/2.0D0
38448 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38450 C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38452 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38455 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38460 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38461 ELSEIF(IPIP.EQ.2)THEN
38462 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38465 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38466 * XDIQP,XVQT,XSQ,XSAQ
38469 C subtract xsq,xsaq from NC1P diquark and NC1T quark
38475 ELSEIF(IPIP.EQ.2)THEN
38480 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38482 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38487 IF(IVTHR.EQ.10)THEN
38490 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38495 XVTHR=XVTHRO/(201-IVTHR)
38498 IF(XVTHR.GT.0.66D0*XDIQP)THEN
38501 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ',
38506 IF(DT_RNDM(V).LT.0.5D0)THEN
38507 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38510 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38514 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38517 C Prepare 4 momenta of new chains and chain ends
38519 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38520 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38522 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38523 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38524 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38530 ELSEIF(IPIP.EQ.2)THEN
38540 JDAHKT(1,1)=3+IIGLU1
38542 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38543 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38544 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38545 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38546 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38547 C PHKT(5,1) =PHKK(5,NC1P)
38548 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38550 IF(XMIST.GE.0.D0)THEN
38551 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38554 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38557 VHKT(1,1) =VHKK(1,NC1P)
38558 VHKT(2,1) =VHKK(2,NC1P)
38559 VHKT(3,1) =VHKK(3,NC1P)
38560 VHKT(4,1) =VHKK(4,NC1P)
38561 WHKT(1,1) =WHKK(1,NC1P)
38562 WHKT(2,1) =WHKK(2,NC1P)
38563 WHKT(3,1) =WHKK(3,NC1P)
38564 WHKT(4,1) =WHKK(4,NC1P)
38565 C Add here IIGLU1 gluons to this chaina
38570 IF(IIGLU1.GE.1)THEN
38572 DO 61 IIG=2,2+IIGLU1-1
38574 IDHKT(IIG) =IDHKK(KKG)
38578 JDAHKT(1,IIG)=3+IIGLU1
38580 PHKT(1,IIG)=PHKK(1,KKG)
38581 PG1=PG1+ PHKT(1,IIG)
38582 PHKT(2,IIG)=PHKK(2,KKG)
38583 PG2=PG2+ PHKT(2,IIG)
38584 PHKT(3,IIG)=PHKK(3,KKG)
38585 PG3=PG3+ PHKT(3,IIG)
38586 PHKT(4,IIG)=PHKK(4,KKG)
38587 PG4=PG4+ PHKT(4,IIG)
38588 PHKT(5,IIG)=PHKK(5,KKG)
38589 VHKT(1,IIG) =VHKK(1,KKG)
38590 VHKT(2,IIG) =VHKK(2,KKG)
38591 VHKT(3,IIG) =VHKK(3,KKG)
38592 VHKT(4,IIG) =VHKK(4,KKG)
38593 WHKT(1,IIG) =WHKK(1,KKG)
38594 WHKT(2,IIG) =WHKK(2,KKG)
38595 WHKT(3,IIG) =WHKK(3,KKG)
38596 WHKT(4,IIG) =WHKK(4,KKG)
38599 IDHKT(2+IIGLU1) =IPP2
38600 ISTHKT(2+IIGLU1) =932
38601 JMOHKT(1,2+IIGLU1)=NC2T
38602 JMOHKT(2,2+IIGLU1)=0
38603 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38604 JDAHKT(2,2+IIGLU1)=0
38605 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38606 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38607 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38608 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38609 C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
38610 XMIST=(PHKT(4,2+IIGLU1)**2-
38611 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38612 *PHKT(1,2+IIGLU1)**2)
38613 IF(XMIST.GT.0.D0)THEN
38614 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38615 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38616 *PHKT(1,2+IIGLU1)**2)
38618 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38619 PHKT(5,2+IIGLU1)=0.D0
38621 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38622 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38623 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38624 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38625 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38626 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38627 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38628 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38629 IDHKT(3+IIGLU1) =88888
38630 ISTHKT(3+IIGLU1) =94
38631 JMOHKT(1,3+IIGLU1)=1
38632 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38633 JDAHKT(1,3+IIGLU1)=0
38634 JDAHKT(2,3+IIGLU1)=0
38635 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38636 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38637 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38638 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38640 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38641 * -PHKT(3,3+IIGLU1)**2)
38642 IF(XMIST.GE.0.D0)THEN
38644 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38645 * -PHKT(3,3+IIGLU1)**2)
38647 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38651 C IF(NUMEV.EQ.-324)THEN
38652 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38653 * JMOHKT(2,1),JDAHKT(1,1),
38654 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38655 DO 71 IIG=2,2+IIGLU1-1
38656 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38657 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38659 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38661 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38662 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38663 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38664 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38665 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38666 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38670 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38671 ELSEIF(IPIP.EQ.2)THEN
38672 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38674 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38678 C WRITE(6,*)' MUSQBS1 jump back from chain 3'
38681 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38682 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38683 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38684 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38685 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38686 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38687 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38688 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38689 IDHKT(4+IIGLU1) =IP12
38690 ISTHKT(4+IIGLU1) =931
38691 JMOHKT(1,4+IIGLU1)=NC1P
38692 JMOHKT(2,4+IIGLU1)=0
38693 JDAHKT(1,4+IIGLU1)=6+IIGLU1
38694 JDAHKT(2,4+IIGLU1)=0
38695 C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38696 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38697 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38698 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38699 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38700 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
38701 XMIST =(PHKT(4,4+IIGLU1)**2-
38702 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38703 *PHKT(1,4+IIGLU1)**2)
38704 IF(XMIST.GT.0.D0)THEN
38705 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
38706 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38707 *PHKT(1,4+IIGLU1)**2)
38709 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38710 PHKT(5,4+IIGLU1)=0.D0
38712 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
38713 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
38714 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
38715 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
38716 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
38717 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
38718 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
38719 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
38721 IDHKT(5+IIGLU1) =-(ISAQ1-6)
38722 ELSEIF(IPIP.EQ.2)THEN
38723 IDHKT(5+IIGLU1) =ISAQ1
38725 ISTHKT(5+IIGLU1) =932
38726 JMOHKT(1,5+IIGLU1)=NC1T
38727 JMOHKT(2,5+IIGLU1)=0
38728 JDAHKT(1,5+IIGLU1)=6+IIGLU1
38729 JDAHKT(2,5+IIGLU1)=0
38730 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38731 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38732 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38733 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38734 C IF( PHKT(4,5).EQ.0.D0)THEN
38739 C PHKT(5,5) =PHKK(5,NC1T)
38740 XMIST=(PHKT(4,5+IIGLU1)**2-
38741 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38742 *PHKT(1,5+IIGLU1)**2)
38743 IF(XMIST.GT.0.D0)THEN
38744 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
38745 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38746 *PHKT(1,5+IIGLU1)**2)
38748 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38749 PHKT(5,5+IIGLU1)=0.D0
38751 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
38752 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
38753 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
38754 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
38755 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
38756 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
38757 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
38758 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
38759 IDHKT(6+IIGLU1) =88888
38760 ISTHKT(6+IIGLU1) =94
38761 JMOHKT(1,6+IIGLU1)=4+IIGLU1
38762 JMOHKT(2,6+IIGLU1)=5+IIGLU1
38763 JDAHKT(1,6+IIGLU1)=0
38764 JDAHKT(2,6+IIGLU1)=0
38765 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38766 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38767 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38768 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38770 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38771 * -PHKT(3,6+IIGLU1)**2)
38772 IF(XMIST.GE.0.D0)THEN
38774 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38775 * -PHKT(3,6+IIGLU1)**2)
38777 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38780 C IF(IPIP.EQ.3)THEN
38783 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38784 ELSEIF(IPIP.EQ.2)THEN
38785 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38787 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38791 C WRITE(6,*)' MGSQBS1 jump back from chain 6',
38792 C * CHAMAL,PHKT(5,6+IIGLU1)
38796 C IF(NUMEV.EQ.-324)THEN
38797 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38798 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38799 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38800 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38801 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38802 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38803 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38804 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38805 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38807 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38808 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38809 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38810 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38811 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38812 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38813 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38814 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38816 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
38817 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38818 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38819 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38820 ELSEIF(IPIP.EQ.2)THEN
38821 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38822 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38823 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38824 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38825 C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38827 ISTHKT(7+IIGLU1) =931
38828 JMOHKT(1,7+IIGLU1)=NC2P
38829 JMOHKT(2,7+IIGLU1)=0
38830 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38831 JDAHKT(2,7+IIGLU1)=0
38832 C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38833 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38834 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38835 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38836 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38837 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38838 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38839 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38841 C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38846 C PHKT(5,7) =PHKK(5,NC2P)
38847 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38848 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38849 *PHKT(1,7+IIGLU1)**2)
38850 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38851 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38852 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38853 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38854 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38855 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38856 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38857 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38858 C Insert here the IIGLU2 gluons
38863 IF(IIGLU2.GE.1)THEN
38865 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38866 KKG=JJG+IIG-7-IIGLU1
38867 IDHKT(IIG) =IDHKK(KKG)
38871 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38873 PHKT(1,IIG)=PHKK(1,KKG)
38874 PG1=PG1+ PHKT(1,IIG)
38875 PHKT(2,IIG)=PHKK(2,KKG)
38876 PG2=PG2+ PHKT(2,IIG)
38877 PHKT(3,IIG)=PHKK(3,KKG)
38878 PG3=PG3+ PHKT(3,IIG)
38879 PHKT(4,IIG)=PHKK(4,KKG)
38880 PG4=PG4+ PHKT(4,IIG)
38881 PHKT(5,IIG)=PHKK(5,KKG)
38882 VHKT(1,IIG) =VHKK(1,KKG)
38883 VHKT(2,IIG) =VHKK(2,KKG)
38884 VHKT(3,IIG) =VHKK(3,KKG)
38885 VHKT(4,IIG) =VHKK(4,KKG)
38886 WHKT(1,IIG) =WHKK(1,KKG)
38887 WHKT(2,IIG) =WHKK(2,KKG)
38888 WHKT(3,IIG) =WHKK(3,KKG)
38889 WHKT(4,IIG) =WHKK(4,KKG)
38892 IDHKT(8+IIGLU1+IIGLU2) =IP2
38893 ISTHKT(8+IIGLU1+IIGLU2) =932
38894 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38895 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38896 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38897 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38898 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38899 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38900 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38901 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38902 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38903 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38904 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38905 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38906 IF(XMIST.GT.0.D0)THEN
38907 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38908 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38909 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38911 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38912 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38914 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38915 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38916 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38917 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38918 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38919 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38920 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38921 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38922 IDHKT(9+IIGLU1+IIGLU2) =88888
38923 ISTHKT(9+IIGLU1+IIGLU2) =94
38924 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38925 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38926 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38927 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38928 PHKT(1,9+IIGLU1+IIGLU2)
38929 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38930 PHKT(2,9+IIGLU1+IIGLU2)
38931 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38932 PHKT(3,9+IIGLU1+IIGLU2)
38933 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38934 PHKT(4,9+IIGLU1+IIGLU2)
38935 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38937 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38938 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38939 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38940 IF(XMIST.GE.0.D0)THEN
38941 PHKT(5,9+IIGLU1+IIGLU2)
38942 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38943 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38944 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38946 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38950 C IF(NUMEV.EQ.-324)THEN
38951 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38952 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38953 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38954 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38955 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38956 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38958 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38960 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38961 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38962 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38963 *JDAHKT(1,8+IIGLU1+IIGLU2),
38964 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38965 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38966 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38967 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38968 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38972 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38973 ELSEIF(IPIP.EQ.2)THEN
38974 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38976 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38980 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38981 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38984 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38985 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38986 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38987 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38988 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38989 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38990 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38991 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38994 IGCOUN=9+IIGLU1+IIGLU2
38998 *$ CREATE MGSQBS1.FOR
39001 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39002 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39003 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
39005 C GSQBS-1 diagram (split projectile diquark)
39007 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39010 PARAMETER ( LINP = 10 ,
39014 PARAMETER (NMXHKK=200000)
39015 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39016 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39017 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39018 * extended event history
39019 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39020 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39022 * Lorentz-parameters of the current interaction
39023 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
39024 & UMO,PPCM,EPROJ,PPROJ
39025 * diquark-breaking mechanism
39026 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39029 PARAMETER (NTMHKK= 300)
39030 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39031 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39034 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39037 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39039 C GSQBS-1 diagram (split projectile diquark)
39042 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39043 C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39045 C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39046 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39048 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39049 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39050 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39052 C Put new chains into COMMON /HKKTMP/
39057 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39059 NNNC1=IDHKK(NC1)/1000
39060 MMMC1=IDHKK(NC1)-NNNC1*1000
39062 NNNC2=IDHKK(NC2)/1000
39063 MMMC2=IDHKK(NC2)-NNNC2*1000
39067 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39068 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39069 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39070 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39075 C determine x-values of NC1P diquark
39076 XDIQP=PHKK(4,NC1P)*2.D0/UMO
39077 XVQT=PHKK(4,NC1T)*2.D0/UMO
39079 C determine x-values of sea quark pair
39085 IF(ICOU.GE.500)THEN
39088 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39092 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
39097 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39098 IF (IPIP.EQ.1) THEN
39099 XQMAX = XDIQP/2.0D0
39100 XAQMAX = 2.D0*XVQT/3.0D0
39102 XQMAX = 2.D0*XVQT/3.0D0
39103 XAQMAX = XDIQP/2.0D0
39105 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39107 C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39110 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39113 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39118 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39119 ELSEIF(IPIP.EQ.2)THEN
39120 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39123 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39124 * XDIQP,XVQT,XSQ,XSAQ
39127 C subtract xsq,xsaq from NC1P diquark and NC1T quark
39133 C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39136 ELSEIF(IPIP.EQ.2)THEN
39141 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39143 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39148 IF(IVTHR.EQ.10)THEN
39151 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39156 XVTHR=XVTHRO/(201-IVTHR)
39159 IF(XVTHR.GT.0.66D0*XDIQP)THEN
39163 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ',
39168 IF(DT_RNDM(V).LT.0.5D0)THEN
39169 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39172 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39176 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39177 * XVTHR,XDIQP,XVPQI,XVPQII
39180 C Prepare 4 momenta of new chains and chain ends
39182 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39183 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39185 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39186 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39187 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39193 ELSEIF(IPIP.EQ.2)THEN
39200 C IDHKT(2) =1000*IPP21+100*IPP22+1
39204 IDHKT(4+IIGLU1) =IP12
39205 ISTHKT(4+IIGLU1) =921
39206 JMOHKT(1,4+IIGLU1)=NC1P
39207 JMOHKT(2,4+IIGLU1)=0
39208 JDAHKT(1,4+IIGLU1)=6+IIGLU1
39209 JDAHKT(2,4+IIGLU1)=0
39211 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39212 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39214 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39215 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39216 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39217 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39218 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
39219 XXMIST=(PHKT(4,4+IIGLU1)**2-
39220 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39221 * PHKT(1,4+IIGLU1)**2)
39222 IF(XXMIST.GT.0.D0)THEN
39223 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39225 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39227 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39229 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
39230 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
39231 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
39232 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
39233 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
39234 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
39235 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
39236 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
39238 IDHKT(5+IIGLU1) =-(ISAQ1-6)
39239 ELSEIF(IPIP.EQ.2)THEN
39240 IDHKT(5+IIGLU1) =ISAQ1
39242 ISTHKT(5+IIGLU1) =922
39243 JMOHKT(1,5+IIGLU1)=NC1T
39244 JMOHKT(2,5+IIGLU1)=0
39245 JDAHKT(1,5+IIGLU1)=6+IIGLU1
39246 JDAHKT(2,5+IIGLU1)=0
39248 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
39249 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39251 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39252 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39253 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39254 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39255 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
39256 XMIST=(PHKT(4,5+IIGLU1)**2-
39257 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39258 *PHKT(1,5+IIGLU1)**2)
39259 IF(XMIST.GT.0.D0)THEN
39260 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
39261 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39262 *PHKT(1,5+IIGLU1)**2)
39264 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39265 PHKT(5,5+IIGLU1)=0.D0
39267 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
39268 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
39269 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
39270 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
39271 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
39272 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
39273 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
39274 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
39275 IDHKT(6+IIGLU1) =88888
39276 C IDHKT(6) =1000*NNNC1+MMMC1
39277 ISTHKT(6+IIGLU1) =93
39279 JMOHKT(1,6+IIGLU1)=4+IIGLU1
39280 JMOHKT(2,6+IIGLU1)=5+IIGLU1
39281 JDAHKT(1,6+IIGLU1)=0
39282 JDAHKT(2,6+IIGLU1)=0
39283 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39284 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39285 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39286 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39288 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39289 * -PHKT(3,6+IIGLU1)**2)
39292 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39293 ELSEIF(IPIP.EQ.2)THEN
39294 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39296 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39297 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39298 C we drop chain 6 and give the energy to chain 3
39299 IDHKT(6+IIGLU1)=33888
39301 C WRITE(6,*)' drop chain 6 xgive=1'
39303 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39304 C we drop chain 6 and give the energy to chain 3
39305 C and change KK11 to IDHKT(4)
39306 IDHKT(6+IIGLU1)=33888
39308 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39309 KK11=IDHKT(4+IIGLU1)
39311 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39312 C we drop chain 6 and give the energy to chain 3
39313 C and change KK21 to IDHKT(4)
39314 C IDHKT(2) =1000*IPP21+100*IPP22+1
39315 IDHKT(6+IIGLU1)=33888
39317 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39318 KK21=IDHKT(4+IIGLU1)
39320 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39321 C we drop chain 6 and give the energy to chain 3
39322 C and change KK22 to IDHKT(4)
39323 C IDHKT(2) =1000*IPP21+100*IPP22+1
39324 IDHKT(6+IIGLU1)=33888
39326 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39327 KK22=IDHKT(4+IIGLU1)
39333 C WRITE(6,*)' MGSQBS1 jump back from chain 6'
39338 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39339 * JMOHKT(1,4+IIGLU1),
39340 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39341 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39342 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39343 * JMOHKT(1,5+IIGLU1),
39344 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39345 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39346 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39347 * JMOHKT(1,6+IIGLU1),
39348 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39349 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39351 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
39352 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
39353 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
39354 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
39355 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
39356 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
39357 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
39358 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
39364 JDAHKT(1,1)=3+IIGLU1
39366 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39367 C * +0.5D0*PHKK(1,NC2P)
39368 *+XGIVE*PHKT(1,4+IIGLU1)
39369 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39370 C * +0.5D0*PHKK(2,NC2P)
39371 *+XGIVE*PHKT(2,4+IIGLU1)
39372 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39373 C * +0.5D0*PHKK(3,NC2P)
39374 *+XGIVE*PHKT(3,4+IIGLU1)
39375 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39376 C * +0.5D0*PHKK(4,NC2P)
39377 *+XGIVE*PHKT(4,4+IIGLU1)
39378 C PHKT(5,1) =PHKK(5,NC1P)
39379 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39381 IF(XMIST.GE.0.D0)THEN
39382 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39385 C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39388 VHKT(1,1) =VHKK(1,NC1P)
39389 VHKT(2,1) =VHKK(2,NC1P)
39390 VHKT(3,1) =VHKK(3,NC1P)
39391 VHKT(4,1) =VHKK(4,NC1P)
39392 WHKT(1,1) =WHKK(1,NC1P)
39393 WHKT(2,1) =WHKK(2,NC1P)
39394 WHKT(3,1) =WHKK(3,NC1P)
39395 WHKT(4,1) =WHKK(4,NC1P)
39396 C Add here IIGLU1 gluons to this chaina
39401 IF(IIGLU1.GE.1)THEN
39403 DO 61 IIG=2,2+IIGLU1-1
39405 IDHKT(IIG) =IDHKK(KKG)
39409 JDAHKT(1,IIG)=3+IIGLU1
39411 PHKT(1,IIG)=PHKK(1,KKG)
39412 PG1=PG1+ PHKT(1,IIG)
39413 PHKT(2,IIG)=PHKK(2,KKG)
39414 PG2=PG2+ PHKT(2,IIG)
39415 PHKT(3,IIG)=PHKK(3,KKG)
39416 PG3=PG3+ PHKT(3,IIG)
39417 PHKT(4,IIG)=PHKK(4,KKG)
39418 PG4=PG4+ PHKT(4,IIG)
39419 PHKT(5,IIG)=PHKK(5,KKG)
39420 VHKT(1,IIG) =VHKK(1,KKG)
39421 VHKT(2,IIG) =VHKK(2,KKG)
39422 VHKT(3,IIG) =VHKK(3,KKG)
39423 VHKT(4,IIG) =VHKK(4,KKG)
39424 WHKT(1,IIG) =WHKK(1,KKG)
39425 WHKT(2,IIG) =WHKK(2,KKG)
39426 WHKT(3,IIG) =WHKK(3,KKG)
39427 WHKT(4,IIG) =WHKK(4,KKG)
39430 C IDHKT(2) =1000*IPP21+100*IPP22+1
39432 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
39433 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39434 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39435 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39436 ELSEIF(IPIP.EQ.2)THEN
39437 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
39438 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39439 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39440 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39442 ISTHKT(2+IIGLU1) =922
39443 JMOHKT(1,2+IIGLU1)=NC2T
39444 JMOHKT(2,2+IIGLU1)=0
39445 JDAHKT(1,2+IIGLU1)=3+IIGLU1
39446 JDAHKT(2,2+IIGLU1)=0
39447 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
39448 *+XGIVE*PHKT(1,5+IIGLU1)
39449 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
39450 *+XGIVE*PHKT(2,5+IIGLU1)
39451 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
39452 *+XGIVE*PHKT(3,5+IIGLU1)
39453 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
39454 *+XGIVE*PHKT(4,5+IIGLU1)
39455 C PHKT(5,2) =PHKK(5,NC2T)
39456 XMIST=(PHKT(4,2+IIGLU1)**2-
39457 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39458 *PHKT(1,2+IIGLU1)**2)
39459 IF(XMIST.GT.0.D0)THEN
39460 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
39461 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39462 *PHKT(1,2+IIGLU1)**2)
39464 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39465 PHKT(5,2+IIGLU1)=0.D0
39467 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
39468 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
39469 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
39470 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
39471 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
39472 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
39473 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
39474 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
39475 IDHKT(3+IIGLU1) =88888
39476 C IDHKT(3) =1000*NNNC1+MMMC1+10
39477 ISTHKT(3+IIGLU1) =93
39479 JMOHKT(1,3+IIGLU1)=1
39480 JMOHKT(2,3+IIGLU1)=2+IIGLU1
39481 JDAHKT(1,3+IIGLU1)=0
39482 JDAHKT(2,3+IIGLU1)=0
39483 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39484 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39485 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39486 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39488 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39489 * -PHKT(3,3+IIGLU1)**2)
39491 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39493 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39494 DO 71 IIG=2,2+IIGLU1-1
39495 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39496 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39498 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39500 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39501 & IDHKT(2),JMOHKT(1,2+IIGLU1),
39502 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39503 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39504 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39505 * JMOHKT(1,3+IIGLU1),
39506 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39507 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39511 C IF(IPIP.EQ.1)THEN
39512 C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39513 C ELSEIF(IPIP.EQ.2)THEN
39514 C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39517 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39518 ELSEIF(IPIP.EQ.2)THEN
39519 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39522 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39526 C WRITE(6,*)' MGSQBS1 jump back from chain 3'
39529 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
39530 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
39531 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
39532 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
39533 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
39534 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
39535 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
39536 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
39538 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
39539 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39540 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39541 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39542 ELSEIF(IPIP.EQ.2)THEN
39543 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
39544 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39545 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39546 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39547 C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39549 ISTHKT(7+IIGLU1) =921
39550 JMOHKT(1,7+IIGLU1)=NC2P
39551 JMOHKT(2,7+IIGLU1)=0
39552 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39553 JDAHKT(2,7+IIGLU1)=0
39554 C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39555 C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39556 C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39557 C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39559 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39560 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39562 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39563 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39564 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39565 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39566 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39567 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39568 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39570 C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39575 C PHKT(5,7) =PHKK(5,NC2P)
39576 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
39577 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39578 *PHKT(1,7+IIGLU1)**2)
39579 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
39580 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
39581 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
39582 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
39583 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
39584 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
39585 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
39586 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
39587 C Insert here the IIGLU2 gluons
39592 IF(IIGLU2.GE.1)THEN
39594 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39595 KKG=JJG+IIG-7-IIGLU1
39596 IDHKT(IIG) =IDHKK(KKG)
39600 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39602 PHKT(1,IIG)=PHKK(1,KKG)
39603 PG1=PG1+ PHKT(1,IIG)
39604 PHKT(2,IIG)=PHKK(2,KKG)
39605 PG2=PG2+ PHKT(2,IIG)
39606 PHKT(3,IIG)=PHKK(3,KKG)
39607 PG3=PG3+ PHKT(3,IIG)
39608 PHKT(4,IIG)=PHKK(4,KKG)
39609 PG4=PG4+ PHKT(4,IIG)
39610 PHKT(5,IIG)=PHKK(5,KKG)
39611 VHKT(1,IIG) =VHKK(1,KKG)
39612 VHKT(2,IIG) =VHKK(2,KKG)
39613 VHKT(3,IIG) =VHKK(3,KKG)
39614 VHKT(4,IIG) =VHKK(4,KKG)
39615 WHKT(1,IIG) =WHKK(1,KKG)
39616 WHKT(2,IIG) =WHKK(2,KKG)
39617 WHKT(3,IIG) =WHKK(3,KKG)
39618 WHKT(4,IIG) =WHKK(4,KKG)
39621 IDHKT(8+IIGLU1+IIGLU2) =IP2
39622 ISTHKT(8+IIGLU1+IIGLU2) =922
39623 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39624 JMOHKT(2,8+IIGLU1+IIGLU2)=0
39625 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39626 JDAHKT(2,8+IIGLU1+IIGLU2)=0
39628 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39629 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39631 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39632 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39633 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39634 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39635 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
39636 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39637 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39638 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39639 IF(XMIST.GT.0.D0)THEN
39640 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39641 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39642 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39644 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39645 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39647 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
39648 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
39649 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
39650 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
39651 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
39652 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
39653 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
39654 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
39655 IDHKT(9+IIGLU1+IIGLU2) =88888
39656 C IDHKT(9) =1000*NNNC2+MMMC2+10
39657 ISTHKT(9+IIGLU1+IIGLU2) =93
39659 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39660 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39661 JDAHKT(1,9+IIGLU1+IIGLU2)=0
39662 JDAHKT(2,9+IIGLU1+IIGLU2)=0
39663 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
39664 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39665 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
39666 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39667 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
39668 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39669 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
39670 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39671 PHKT(5,9+IIGLU1+IIGLU2)
39672 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39673 * PHKT(2,9+IIGLU1+IIGLU2)**2
39674 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
39676 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39677 * JMOHKT(1,7+IIGLU1),
39678 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39679 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39680 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39681 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39682 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39684 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39686 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39687 * IDHKT(8+IIGLU1+IIGLU2),
39688 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39689 * JDAHKT(1,8+IIGLU1+IIGLU2),
39690 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39691 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39692 * IDHKT(9+IIGLU1+IIGLU2),
39693 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39694 * JDAHKT(1,9+IIGLU1+IIGLU2),
39695 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39699 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39700 ELSEIF(IPIP.EQ.2)THEN
39701 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39703 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39707 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
39708 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39711 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
39712 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
39713 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
39714 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
39715 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
39716 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
39717 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
39718 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
39720 IGCOUN=9+IIGLU1+IIGLU2
39725 *$ CREATE HKKHKT.FOR
39728 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39730 SUBROUTINE HKKHKT(I,J)
39731 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39735 PARAMETER (NMXHKK=200000)
39736 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39737 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39738 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39739 * extended event history
39740 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39741 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39744 PARAMETER (NTMHKK= 300)
39745 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39746 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39749 ISTHKK(I) =ISTHKT(J)
39751 C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39752 IF(IDHKK(I).EQ.88888)THEN
39755 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39756 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39758 JMOHKK(1,I)=JMOHKT(1,J)
39759 JMOHKK(2,I)=JMOHKT(2,J)
39761 JDAHKK(1,I)=JDAHKT(1,J)
39762 JDAHKK(2,I)=JDAHKT(2,J)
39763 C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39765 C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39768 IF(JDAHKT(1,J).GT.0)THEN
39769 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39771 PHKK(1,I) =PHKT(1,J)
39772 PHKK(2,I) =PHKT(2,J)
39773 PHKK(3,I) =PHKT(3,J)
39774 PHKK(4,I) =PHKT(4,J)
39775 PHKK(5,I) =PHKT(5,J)
39776 VHKK(1,I) =VHKT(1,J)
39777 VHKK(2,I) =VHKT(2,J)
39778 VHKK(3,I) =VHKT(3,J)
39779 VHKK(4,I) =VHKT(4,J)
39780 WHKK(1,I) =WHKT(1,J)
39781 WHKK(2,I) =WHKT(2,J)
39782 WHKK(3,I) =WHKT(3,J)
39783 WHKK(4,I) =WHKT(4,J)
39787 *$ CREATE DT_DBREAK.FOR
39790 *===dbreak=============================================================*
39792 SUBROUTINE DT_DBREAK(MODE)
39794 ************************************************************************
39795 * This is the steering subroutine for the different diquark breaking *
39798 * MODE = 1 breaking of projectile diquark in qq-q chain using *
39799 * a sea quark (q-qq chain) of the same projectile *
39800 * = 2 breaking of target diquark in q-qq chain using *
39801 * a sea quark (qq-q chain) of the same target *
39802 * = 3 breaking of projectile diquark in qq-q chain using *
39803 * a sea quark (q-aq chain) of the same projectile *
39804 * = 4 breaking of target diquark in q-qq chain using *
39805 * a sea quark (aq-q chain) of the same target *
39806 * = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
39807 * a sea anti-quark (aq-aqaq chain) of the same projectile *
39808 * = 6 breaking of target anti-diquark in aq-aqaq chain using *
39809 * a sea anti-quark (aqaq-aq chain) of the same target *
39810 * = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
39811 * a sea anti-quark (aq-q chain) of the same projectile *
39812 * = 8 breaking of target anti-diquark in aq-aqaq chain using *
39813 * a sea anti-quark (q-aq chain) of the same target *
39815 * Original version by J. Ranft. *
39816 * This version dated 17.5.00 is written by S. Roesler. *
39817 ************************************************************************
39819 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39821 PARAMETER ( LINP = 10 ,
39826 PARAMETER (NMXHKK=200000)
39827 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39828 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39829 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39830 * extended event history
39831 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39832 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39834 * flags for input different options
39835 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39836 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39837 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39838 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39839 PARAMETER (MAXCHN=10000)
39840 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39841 * diquark-breaking mechanism
39842 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39843 * flags for particle decays
39844 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39845 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39846 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39849 * chain identifiers
39850 * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
39851 * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39852 DIMENSION IDCHN1(8),IDCHN2(8)
39853 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39854 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39856 * parton identifiers
39857 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39858 * +-51/52 = unitarity-sea, +-61/62 = gluons )
39859 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39860 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39861 & 31, 31, 31, 31, 31, 31, 31, 31,
39862 & 41, 41, 41, 41, 51, 51, 51, 51/
39863 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39864 & 32, 32, 32, 32, 32, 32, 32, 32,
39865 & 42, 42, 42, 42, 52, 52, 52, 52/
39866 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39867 & 51, 31, 41, 41, 31, 31, 31, 31,
39868 & 0, 41, 51, 51, 51, 51, 51, 51/
39869 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39870 & 32, 52, 42, 42, 32, 32, 32, 32,
39871 & 42, 0, 52, 52, 52, 52, 52, 52/
39873 IF (NCHAIN.LE.0) RETURN
39876 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39877 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39878 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39880 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39881 & (IS1P.EQ.ISP1P(MODE,3)))
39883 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39884 & (IS1T.EQ.ISP1T(MODE,3)))
39888 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39889 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39890 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39892 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39893 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
39895 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39896 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
39898 * find mother nucleons of the diquark to be splitted and of the
39899 * sea-quark and reject this combination if it is not the same
39900 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39901 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39906 IDXMO1 = JMOHKK(IANCES,IDX1)
39908 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39909 & (JMOHKK(2,IDXMO1).NE.0)) THEN
39914 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39915 IDXMO1 = JMOHKK(IANC,IDXMO1)
39918 IDXMO2 = JMOHKK(IANCES,IDX2)
39920 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39921 & (JMOHKK(2,IDXMO2).NE.0)) THEN
39926 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39927 IDXMO2 = JMOHKK(IANC,IDXMO2)
39930 IF (IDXMO1.NE.IDXMO2) GOTO 2
39931 * quark content of projectile parton
39932 IP1 = IDHKK(JMOHKK(1,IDX1))
39934 IP12 = (IP1-1000*IP11)/100
39935 IP2 = IDHKK(JMOHKK(2,IDX1))
39937 IP22 = (IP2-1000*IP21)/100
39938 * quark content of target parton
39939 IT1 = IDHKK(JMOHKK(1,IDX2))
39941 IT12 = (IT1-1000*IT11)/100
39942 IT2 = IDHKK(JMOHKK(2,IDX2))
39944 IT22 = (IT2-1000*IT21)/100
39945 * split diquark and form new chains
39946 IF (MODE.EQ.1) THEN
39947 IF (IT1.EQ.4) GOTO 2
39948 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39949 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39950 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39951 ELSEIF (MODE.EQ.2) THEN
39952 IF (IT2.EQ.4) GOTO 2
39953 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39954 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39955 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39956 ELSEIF (MODE.EQ.3) THEN
39957 IF (IT1.EQ.4) GOTO 2
39958 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39959 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39960 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39961 ELSEIF (MODE.EQ.4) THEN
39962 IF (IT2.EQ.4) GOTO 2
39963 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39964 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39965 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39966 ELSEIF (MODE.EQ.5) THEN
39967 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39968 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39969 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39970 ELSEIF (MODE.EQ.6) THEN
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,2,IPQ,IGCOUN)
39974 ELSEIF (MODE.EQ.7) THEN
39975 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39976 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39977 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39978 ELSEIF (MODE.EQ.8) THEN
39979 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39980 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39981 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
39983 IF (IREJ.GE.1) THEN
39984 if ((ipq.lt.0).or.(ipq.ge.4))
39985 & write(LOUT,*) 'ipq !!!',ipq,mode
39986 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39987 * accept or reject new chains corresponding to PDBSEA
39989 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
39990 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
39991 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
39992 ELSEIF (IPQ.EQ.3) THEN
39993 ACC = DBRKA(3,MODE)
39994 REJ = DBRKR(3,MODE)
39996 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
39999 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
40000 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
40003 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
40006 * new chains have been accepted and are now copied into HKKEVT
40007 IF (IACC.EQ.1) THEN
40009 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
40010 & PHKK(3,IDX1),PHKK(4,IDX1),
40012 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
40013 & PHKK(3,IDX2),PHKK(4,IDX2),
40016 IDHKK(IDX1) = 99888
40017 IDHKK(IDX2) = 99888
40022 CALL HKKHKT(NHKK,K)
40023 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
40028 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
40033 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
40035 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40047 *$ CREATE DT_CQPAIR.FOR
40050 *===cqpair=============================================================*
40052 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40054 ************************************************************************
40055 * This subroutine Creates a Quark-antiquark PAIR from the sea. *
40057 * XQMAX maxium energy fraction of quark (input) *
40058 * XAQMAX maxium energy fraction of antiquark (input) *
40059 * XQ energy fraction of quark (output) *
40060 * XAQ energy fraction of antiquark (output) *
40061 * IFLV quark flavour (- antiquark flavor) (output) *
40063 * This version dated 14.5.00 is written by S. Roesler. *
40064 ************************************************************************
40066 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40068 PARAMETER ( LINP = 10 ,
40072 * Lorentz-parameters of the current interaction
40073 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40074 & UMO,PPCM,EPROJ,PPROJ
40081 * sample quark flavour
40083 * set seasq here (the one from DTCHAI should be used in the future)
40085 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40087 * sample energy fractions of sea pair
40088 * we first sample the energy fraction of a gluon and then split the gluon
40090 * maximum energy fraction of the gluon forced via input
40091 XGMAXI = XQMAX+XAQMAX
40092 * minimum energy fraction of the gluon
40093 XTHR1 = 4.0D0 /UMO**2
40094 XTHR2 = 0.54D0/UMO**1.5D0
40095 XGMIN = MAX(XTHR1,XTHR2)
40096 * maximum energy fraction of the gluon
40098 XGMAX = MIN(XGMAXI,XGMAX)
40099 IF (XGMIN.GE.XGMAX) THEN
40104 * sample energy fraction of the gluon
40108 IF (NLOOP.GE.50) THEN
40112 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40113 EGLUON = XGLUON*UMO/2.0D0
40115 * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40116 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40119 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40121 IF (RQ.LT.0.5D0) THEN
40128 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1