4 * +-------------------------------------------------------------+
10 * | S. Roesler+), R. Engel#), J. Ranft*) |
13 * | CH-1211 Geneva 23, Switzerland |
14 * | Email: Stefan.Roesler@cern.ch |
16 * | #) Institut fuer Kernphysik |
17 * | Forschungszentrum Karlsruhe |
18 * | D-76021 Karlsruhe, Germany |
20 * | *) University of Siegen, Dept. of Physics |
21 * | D-57068 Siegen, Germany |
24 * | http://home.cern.ch/sroesler/dpmjet3.html |
27 * | Monte Carlo models used for event generation: |
28 * | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 |
30 * +-------------------------------------------------------------+
33 *===init===============================================================*
35 SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
38 ************************************************************************
39 * Initialization of event generation *
40 * This version dated 7.4.98 is written by S. Roesler. *
42 * Last change 27.12.2006 by S. Roesler. *
43 ************************************************************************
45 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
48 PARAMETER ( LINP = 10 ,
51 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
53 * particle properties (BAMJET index convention)
55 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
56 & IICH(210),IIBAR(210),K1(210),K2(210)
57 * names of hadrons used in input-cards
59 COMMON /DTPAIN/ BTYPE(30)
60 * (original name: PAREVT)
61 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
62 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
63 PARAMETER ( NALLWP = 39 )
64 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
65 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
66 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
67 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
68 * (original name: INPFLG)
69 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
70 * (original name: FRBKCM)
71 PARAMETER ( MXFFBK = 6 )
72 PARAMETER ( MXZFBK = 9 )
73 PARAMETER ( MXNFBK = 10 )
74 PARAMETER ( MXAFBK = 16 )
75 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
76 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
77 PARAMETER ( NXAFBK = MXAFBK + 1 )
78 PARAMETER ( MXPSST = 300 )
79 PARAMETER ( MXPSFB = 41000 )
80 LOGICAL LFRMBK, LNCMSS
81 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
82 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
83 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
84 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
85 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
86 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
87 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
88 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
89 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
90 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
92 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
94 * Glauber formalism: parameters
95 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
96 & BMAX(NCOMPX),BSTEP(NCOMPX),
97 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
99 * Glauber formalism: cross sections
100 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
101 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
102 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
103 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
104 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
105 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
106 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
107 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
108 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
109 & BSLOPE,NEBINI,NQBINI
110 * interface HADRIN-DPM
111 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
112 * central particle production, impact parameter biasing
113 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
114 * parameter for intranuclear cascade
116 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
117 * various options for treatment of partons (DTUNUC 1.x)
118 * (chain recombination, Cronin,..)
119 LOGICAL LCO2CR,LINTPT
120 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
122 * threshold values for x-sampling (DTUNUC 1.x)
123 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
125 * flags for input different options
126 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
127 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
128 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
131 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
132 & EBINDP(2),EBINDN(2),EPOT(2,210),
133 & ETACOU(2),ICOUL,LFERMI
134 * n-n cross section fluctuations
135 PARAMETER (NBINS = 1000)
136 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
137 * flags for particle decays
138 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
139 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
140 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
141 * diquark-breaking mechanism
142 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
143 * nucleon-nucleon event-generator
146 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
147 * properties of interacting particles
148 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
149 * properties of photon/lepton projectiles
150 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
151 * flags for diffractive interactions (DTUNUC 1.x)
152 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
153 * parameters for hA-diffraction
154 COMMON /DTDIHA/ DIBETA,DIALPH
155 * Lorentz-parameters of the current interaction
156 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
157 & UMO,PPCM,EPROJ,PPROJ
158 * kinematical cuts for lepton-nucleus interactions
159 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
160 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
161 * VDM parameter for photon-nucleus interactions
162 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
163 * Glauber formalism: flags and parameters for statistics
166 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
167 * cuts for variable energy runs
168 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
169 * flags for activated histograms
170 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
171 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
172 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
174 **LUND single / double precision
175 REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
176 COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
177 & TMPX,TMPY,TMPW2,TMPQ2,TMPU
180 COMMON /LEPTOI/ RPPN,LEPIN,INTER
181 * steering flags for qel neutrino scattering modules
182 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
184 COMMON /DTEVNO/ NEVENT,ICASCA
189 DIMENSION XDUMB(40),IPRANG(5)
191 PARAMETER (MXCARD=58)
192 CHARACTER*78 CLINE,CTITLE
194 CHARACTER*8 BLANK,SDUM
195 CHARACTER*10 CODE,CODEWD
197 LOGICAL LSTART,LEINP,LXSTAB
198 DIMENSION WHAT(6),CODE(MXCARD)
200 & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ',
201 & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ',
202 & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ',
203 & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ',
204 & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ',
205 & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ',
206 & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ',
207 & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ',
208 & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ',
209 & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
210 & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ',
211 & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ',
212 & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ',
213 & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
217 DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
220 *---------------------------------------------------------------------
221 * at the first call of INIT: initialize event generation
225 * initialization and test of the random number generator
226 IF (ITRSPT.NE.1) THEN
227 CALL DT_RNDMST(22,54,76,92)
230 * initialization of BAMJET, DECAY and HADRIN
235 * set default values for input variables
236 CALL DT_DEFAUL(EPN,PPN)
239 * flag for collision energy input
244 *---------------------------------------------------------------------
247 * bypass reading input cards (e.g. for use with Fluka)
248 * in this case Epn is expected to carry the beam momentum
249 IF (NCASES.EQ.-1) THEN
263 * read control card from input-unit LINP
264 READ(LINP,'(A78)',END=9999) CLINE
265 IF (CLINE(1:1).EQ.'*') THEN
267 WRITE(LOUT,'(A78)') CLINE
270 C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
271 C1000 FORMAT(A10,6E10.0,A8)
275 READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
276 1006 FORMAT(A10,A60,A8)
277 READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
279 WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
280 1001 FORMAT(A10,6G10.3,A8)
284 * check for valid control card and get card index
287 IF (CODEWD.EQ.CODE(I)) ICW = I
290 WRITE(LOUT,1002) CODEWD
291 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
296 *------------------------------------------------------------
297 * TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM,
298 & 100 , 110 , 120 , 130 , 140 ,
300 *------------------------------------------------------------
301 * CMENERGY, EMULSION, FERMI , TAUFOR , PAULI ,
302 & 150 , 160 , 170 , 180 , 190 ,
304 *------------------------------------------------------------
305 * COULOMB , HADRIN , EVAP , EMCCHECK, MODEL ,
306 & 200 , 210 , 220 , 230 , 240 ,
308 *------------------------------------------------------------
309 * PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN,
310 & 250 , 260 , 270 , 280 , 290 ,
312 *------------------------------------------------------------
313 * COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR,
314 & 300 , 310 , 320 , 330 , 340 ,
316 *------------------------------------------------------------
317 * SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH,
318 & 350 , 360 , 370 , 380 , 390 ,
320 *------------------------------------------------------------
321 * NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM ,
322 & 400 , 410 , 420 , 430 , 440 ,
324 *------------------------------------------------------------
325 * LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
326 & 450 , 451 , 452 , 460 , 470 ,
328 *------------------------------------------------------------
329 * OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT,
330 & 480 , 490 , 500 , 510 , 520 ,
332 *------------------------------------------------------------
333 * VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
334 & 530 , 540 , 550 , 560 , 565 ,
336 *------------------------------------------------------------
337 * , , VDM-PAR2, XS-QELPRO, RNDMINIT ,
340 *------------------------------------------------------------
341 * LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP )
342 & 600 , 610 , 620 , 630 , 640 ) , ICW
344 *------------------------------------------------------------
348 *********************************************************************
350 * control card: codewd = TITLE *
352 * what (1..6), sdum no meaning *
354 * Note: The control-card following this must consist of *
355 * a string of characters usually giving the title of *
358 *********************************************************************
361 READ(LINP,'(A78)') CTITLE
362 WRITE(LOUT,'(//,5X,A78,//)') CTITLE
365 *********************************************************************
367 * control card: codewd = PROJPAR *
369 * what (1) = mass number of projectile nucleus default: 1 *
370 * what (2) = charge of projectile nucleus default: 1 *
371 * what (3..6) no meaning *
372 * sdum projectile particle code word *
374 * Note: If sdum is defined what (1..2) have no meaning. *
376 *********************************************************************
379 IF (SDUM.EQ.BLANK) THEN
387 IF (SDUM.EQ.BTYPE(II)) THEN
392 ELSEIF (II.EQ.27) THEN
394 ELSEIF (II.EQ.28) THEN
396 ELSEIF (II.EQ.29) THEN
401 IBPROJ = IIBAR(IJPROJ)
403 IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
405 IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
406 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
407 & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
410 IF (IJPROJ.EQ.0) THEN
412 1110 FORMAT(/,1X,'invalid PROJPAR card !',/)
418 *********************************************************************
420 * control card: codewd = TARPAR *
422 * what (1) = mass number of target nucleus default: 1 *
423 * what (2) = charge of target nucleus default: 1 *
424 * what (3..6) no meaning *
425 * sdum target particle code word *
427 * Note: If sdum is defined what (1..2) have no meaning. *
429 *********************************************************************
432 IF (SDUM.EQ.BLANK) THEN
440 IF (SDUM.EQ.BTYPE(II)) THEN
444 IBTARG = IIBAR(IJTARG)
447 IF (IJTARG.EQ.0) THEN
449 1120 FORMAT(/,1X,'invalid TARPAR card !',/)
455 *********************************************************************
457 * control card: codewd = ENERGY *
459 * what (1) = energy (GeV) of projectile in Lab. *
460 * if what(1) < 0: |what(1)| = kinetic energy *
462 * if |what(2)| > 0: min. energy for variable *
464 * what (2) = max. energy for variable energy runs *
465 * if what(2) < 0: |what(2)| = kinetic energy *
467 *********************************************************************
473 IF ((ABS(WHAT(2)).GT.ZERO).AND.
474 & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
482 *********************************************************************
484 * control card: codewd = MOMENTUM *
486 * what (1) = momentum (GeV/c) of projectile in Lab. *
487 * default: 200 GeV/c *
488 * what (2..6), sdum no meaning *
490 *********************************************************************
499 *********************************************************************
501 * control card: codewd = CMENERGY *
503 * what (1) = energy in nucleon-nucleon cms. *
505 * what (2..6), sdum no meaning *
507 *********************************************************************
516 *********************************************************************
518 * control card: codewd = EMULSION *
520 * definition of nuclear emulsions *
522 * what(1) mass number of emulsion component *
523 * what(2) charge of emulsion component *
524 * what(3) fraction of events in which a scattering on a *
525 * nucleus of this properties is performed *
526 * what(4,5,6) as what(1,2,3) but for another component *
527 * default: no emulsion *
530 * Note: If this input-card is once used with valid parameters *
531 * TARPAR is obsolete. *
532 * Not the absolute values of the fractions are important *
533 * but only the ratios of fractions of different comp. *
534 * This control card can be repeatedly used to define *
535 * emulsions consisting of up to 10 elements. *
537 *********************************************************************
540 IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
541 & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
543 IF (NCOMPO.GT.NCOMPX) THEN
547 IEMUMA(NCOMPO) = INT(WHAT(1))
548 IEMUCH(NCOMPO) = INT(WHAT(2))
549 EMUFRA(NCOMPO) = WHAT(3)
551 C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
553 IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
554 & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
556 IF (NCOMPO.GT.NCOMPX) THEN
560 IEMUMA(NCOMPO) = INT(WHAT(4))
561 IEMUCH(NCOMPO) = INT(WHAT(5))
562 EMUFRA(NCOMPO) = WHAT(6)
563 C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
565 1600 FORMAT(1X,'too many emulsion components - program stopped')
568 *********************************************************************
570 * control card: codewd = FERMI *
572 * what (1) = -1 Fermi-motion of nucleons not treated *
574 * what (2) = scale factor for Fermi-momentum *
576 * what (3..6), sdum no meaning *
578 *********************************************************************
581 IF (WHAT(1).EQ.-1.0D0) THEN
587 IF (XMOD.GE.ZERO) FERMOD = XMOD
590 *********************************************************************
592 * control card: codewd = TAUFOR *
594 * formation time supressed intranuclear cascade *
596 * what (1) formation time (in fm/c) *
597 * note: what(1)=10. corresponds roughly to an *
598 * average formation time of 1 fm/c *
600 * what (2) number of generations followed *
602 * what (3) = 1. p_t-dependent formation zone *
603 * = 2. constant formation zone *
605 * what (4) modus of selection of nucleus where the *
606 * cascade if followed first *
607 * = 1. proj./target-nucleus with probab. 1/2 *
608 * = 2. nucleus with highest mass *
609 * = 3. proj. nucleus if particle is moving in pos. z *
610 * targ. nucleus if particle is moving in neg. z *
612 * what (5..6), sdum no meaning *
614 *********************************************************************
618 KTAUGE = INT(WHAT(2))
620 IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
621 & ITAUVE = INT(WHAT(3))
622 IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
623 & INCMOD = INT(WHAT(4))
626 *********************************************************************
628 * control card: codewd = PAULI *
630 * what (1) = -1 Pauli's principle for secondary *
631 * interactions not treated *
633 * what (2..6), sdum no meaning *
635 *********************************************************************
638 IF (WHAT(1).EQ.-1.0D0) THEN
645 *********************************************************************
647 * control card: codewd = COULOMB *
649 * what (1) = -1. Coulomb-energy treatment switched off *
651 * what (2..6), sdum no meaning *
653 *********************************************************************
657 IF (WHAT(1).EQ.-1.0D0) THEN
664 *********************************************************************
666 * control card: codewd = HADRIN *
670 * what (1) = 0. elastic/inelastic interactions with probab. *
671 * as defined by cross-sections *
672 * = 1. inelastic interactions forced *
673 * = 2. elastic interactions forced *
675 * what (2) upper threshold in total energy (GeV) below *
676 * which interactions are sampled by HADRIN *
678 * what (3..6), sdum no meaning *
680 *********************************************************************
684 IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
685 IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
688 *********************************************************************
690 * control card: codewd = EVAP *
692 * evaporation module *
694 * what (1) =< -1 ==> evaporation is switched off *
695 * >= 1 ==> evaporation is performed *
697 * what (1) = i1 + i2*10 + i3*100 + i4*10000 *
698 * (i1, i2, i3, i4 >= 0 ) *
700 * i1 is the flag for selecting the T=0 level density option used *
701 * = 1: standard EVAP level densities with Cook pairing *
703 * = 2: Z,N-dependent Gilbert & Cameron level densities *
705 * = 3: Julich A-dependent level densities *
706 * = 4: Z,N-dependent Brancazio & Cameron level densities *
708 * i2 >= 1: high energy fission activated *
709 * (default high energy fission activated) *
711 * i3 = 0: No energy dependence for level densities *
712 * = 1: Standard Ignyatuk (1975, 1st) energy dependence *
713 * for level densities (default) *
714 * = 2: Standard Ignyatuk (1975, 1st) energy dependence *
715 * for level densities with NOT used set of parameters *
716 * = 3: Standard Ignyatuk (1975, 1st) energy dependence *
717 * for level densities with NOT used set of parameters *
718 * = 4: Second Ignyatuk (1975, 2nd) energy dependence *
719 * for level densities *
720 * = 5: Second Ignyatuk (1975, 2nd) energy dependence *
721 * for level densities with fit 1 Iljinov & Mebel set of *
723 * = 6: Second Ignyatuk (1975, 2nd) energy dependence *
724 * for level densities with fit 2 Iljinov & Mebel set of *
726 * = 7: Second Ignyatuk (1975, 2nd) energy dependence *
727 * for level densities with fit 3 Iljinov & Mebel set of *
729 * = 8: Second Ignyatuk (1975, 2nd) energy dependence *
730 * for level densities with fit 4 Iljinov & Mebel set of *
733 * i4 >= 1: Original Gilbert and Cameron pairing energies used *
734 * (default Cook's modified pairing energies) *
736 * what (2) = ig + 10 * if (ig and if must have the same sign) *
738 * ig =< -1 ==> deexcitation gammas are not produced *
739 * (if the evaporation step is not performed *
740 * they are never produced) *
741 * if =< -1 ==> Fermi Break Up is not invoked *
742 * (if the evaporation step is not performed *
743 * it is never invoked) *
744 * The default is: deexcitation gamma produced and Fermi break up *
745 * activated for the new preequilibrium, not *
746 * activated otherwise. *
747 * what (3..6), sdum no meaning *
749 *********************************************************************
753 1009 FORMAT(1X,/,'Warning! Evaporation request rejected since',
754 & ' evaporation modules not available with this version.')
764 *********************************************************************
766 * control card: codewd = EMCCHECK *
768 * extended energy-momentum / quantum-number conservation check *
770 * what (1) = -1 extended check not performed *
772 * what (2..6), sdum no meaning *
774 *********************************************************************
777 IF (WHAT(1).EQ.-1) THEN
784 *********************************************************************
786 * control card: codewd = MODEL *
788 * Model to be used to treat nucleon-nucleon interactions *
790 * sdum = DTUNUC two-chain model *
791 * = PHOJET multiple chains including minijets *
793 * = QNEUTRIN quasi-elastic neutrino scattering *
797 * what (1) (variable INTER) *
798 * = 1 gamma exchange *
801 * = 4 gamma/Z0 exchange *
803 * if sdum = QNEUTRIN: *
804 * what (1) = 0 elastic scattering on nucleon and *
805 * tau does not decay (default) *
806 * = 1 decay of tau into mu.. *
807 * = 2 decay of tau into e.. *
808 * = 10 CC events on p and n *
809 * = 11 NC events on p and n *
811 * what (2..6) no meaning *
813 *********************************************************************
816 IF (SDUM.EQ.CMODEL(1)) THEN
818 ELSEIF (SDUM.EQ.CMODEL(2)) THEN
820 ELSEIF (SDUM.EQ.CMODEL(3)) THEN
822 IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
823 & INTER = INT(WHAT(1))
824 ELSEIF (SDUM.EQ.CMODEL(4)) THEN
827 IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
828 & (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
831 STOP ' Unknown model !'
835 *********************************************************************
837 * control card: codewd = PHOINPUT *
839 * Start of input-section for PHOJET-specific input-cards *
840 * Note: This section will not be finished before giving *
842 * what (1..6), sdum no meaning *
844 *********************************************************************
848 CALL PHO_INIT(LINP,LOUT,IREJ1)
850 WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed'
857 *********************************************************************
859 * control card: codewd = GLAUBERI *
861 * Pre-initialization of impact parameter selection *
863 * what (1..6), sdum no meaning *
865 *********************************************************************
868 IF (IFIRST.NE.99) THEN
869 CALL DT_RNDMST(12,34,56,78)
871 OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
872 C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
883 ADP = (APHI-APLOW)/DBLE(IPPN)
904 IT = ITLOW+(NCIT-1)*IDIT
907 C IIP = (IPHI-IPLOW)/IDIP
908 C IF (IIP.EQ.0) IIP = 1
909 C IF (IT.EQ.IPLOW) IIP = 0
913 CC IF (NCIP.LE.IIP) THEN
914 C IP = IPLOW+(NCIP-1)*IDIP
918 IF (IP.GT.IT) GOTO 472
921 APPN = APLOW+DBLE(NCP-1)*ADP
924 OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
925 WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
932 CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
933 CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
936 C IF ((IP.GT.10).OR.(IT.GT.10)) THEN
944 CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
945 SIGAV = SIGAV+XSPRO(1,1,1)
948 CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
954 C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
957 C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
958 C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
968 *********************************************************************
970 * control card: codewd = FLUCTUAT *
972 * Treatment of cross section fluctuations *
974 * what (1) = 1 treat cross section fluctuations *
976 * what (1..6), sdum no meaning *
978 *********************************************************************
982 IF (WHAT(1).EQ.ONE) THEN
988 *********************************************************************
990 * control card: codewd = CENTRAL *
992 * what (1) = 1. central production forced default: 0 *
993 * if what (1) < 0 and > -100 *
994 * what (2) = min. impact parameter default: 0 *
995 * what (3) = max. impact parameter default: b_max *
996 * if what (1) < -99 *
997 * what (2) = fraction of cross section default: 1 *
998 * if what (1) = -1 : evaporation/fzc suppressed *
999 * if what (1) < -1 : evaporation/fzc allowed *
1001 * what (4..6), sdum no meaning *
1003 *********************************************************************
1006 ICENTR = INT(WHAT(1))
1007 IF (ICENTR.LT.0) THEN
1008 IF (ICENTR.GT.-100) THEN
1017 *********************************************************************
1019 * control card: codewd = RECOMBIN *
1021 * Chain recombination *
1022 * (recombine S-S and V-V chains to V-S chains) *
1024 * what (1) = -1. recombination switched off default: 1 *
1025 * what (2..6), sdum no meaning *
1027 *********************************************************************
1031 IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1034 *********************************************************************
1036 * control card: codewd = COMBIJET *
1038 * chain fusion (2 q-aq --> qq-aqaq) *
1040 * what (1) = 1 fusion treated *
1042 * what (2) minimum number of uncombined chains from *
1043 * single projectile or target nucleons *
1045 * what (3..6), sdum no meaning *
1047 *********************************************************************
1051 IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1052 IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1055 *********************************************************************
1057 * control card: codewd = XCUTS *
1059 * thresholds for x-sampling *
1061 * what (1) defines lower threshold for val.-q x-value (CVQ) *
1063 * what (2) defines lower threshold for val.-qq x-value (CDQ) *
1065 * what (3) defines lower threshold for sea-q x-value (CSEA) *
1067 * what (4) sea-q x-values in S-S chains (SSMIMA) *
1069 * what (5) not used *
1071 * what (6), sdum no meaning *
1073 * Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1075 *********************************************************************
1078 IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1)
1079 IF (WHAT(2).GE.ONE) CDQ = WHAT(2)
1080 IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3)
1081 IF (WHAT(4).GE.ZERO) THEN
1085 IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1088 *********************************************************************
1090 * control card: codewd = INTPT *
1092 * what (1) = -1 intrinsic transverse momenta of partons *
1093 * not treated default: 1 *
1094 * what (2..6), sdum no meaning *
1096 *********************************************************************
1099 IF (WHAT(1).EQ.-1.0D0) THEN
1106 *********************************************************************
1108 * control card: codewd = CRONINPT *
1110 * Cronin effect (multiple scattering of partons at chain ends) *
1112 * what (1) = -1 Cronin effect not treated default: 1 *
1113 * what (2) = 0 scattering parameter default: 0.64 *
1114 * what (3..6), sdum no meaning *
1116 *********************************************************************
1119 IF (WHAT(1).EQ.-1.0D0) THEN
1127 *********************************************************************
1129 * control card: codewd = SEADISTR *
1131 * what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. *
1132 * what (2) (UNON) default: 2. *
1133 * what (3) (UNOM) default: 1.5 *
1134 * what (4) (UNOSEA) default: 5. *
1135 * qdis(x) prop. (1-x)**what (1) etc. *
1136 * what (5..6), sdum no meaning *
1138 *********************************************************************
1142 XSEACU = 1.05D0-XSEACO
1144 IF (UNON.LT.0.1D0) UNON = 2.0D0
1146 IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1148 IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1151 *********************************************************************
1153 * control card: codewd = SEASU3 *
1155 * Treatment of strange-quarks at chain ends *
1157 * what (1) (SEASQ) strange-quark supression factor *
1158 * iflav = 1.+rndm*(2.+SEASQ) *
1160 * what (2..6), sdum no meaning *
1162 *********************************************************************
1168 *********************************************************************
1170 * control card: codewd = DIQUARKS *
1172 * what (1) = -1. sea-diquark/antidiquark-pairs not treated *
1174 * what (2..6), sdum no meaning *
1176 *********************************************************************
1179 IF (WHAT(1).EQ.-1.0D0) THEN
1186 *********************************************************************
1188 * control card: codewd = RESONANC *
1190 * treatment of low mass chains *
1192 * what (1) = -1 low chain masses are not corrected for resonance *
1193 * masses (obsolete for BAMJET-fragmentation) *
1195 * what (2) = -1 massless partons default: 1. (massive) *
1196 * default: 1. (massive) *
1197 * what (3) = -1 chain-system containing chain of too small *
1198 * mass is rejected (note: this does not fully *
1199 * apply to S-S chains) default: 0. *
1200 * what (4..6), sdum no meaning *
1202 *********************************************************************
1208 IF (WHAT(1).EQ.-ONE) IRESCO = 0
1209 IF (WHAT(2).EQ.-ONE) IMSHL = 0
1210 IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1213 *********************************************************************
1215 * control card: codewd = DIFFRACT *
1217 * Treatment of diffractive events *
1219 * what (1) = (ISINGD) 0 no single diffraction *
1220 * 1 single diffraction included *
1221 * +-2 single diffractive events only *
1222 * +-3 projectile single diffraction only *
1223 * +-4 target single diffraction only *
1224 * -5 double pomeron exchange only *
1225 * (neg. sign applies to PHOJET events) *
1228 * what (2) = (IDOUBD) 0 no double diffraction *
1229 * 1 double diffraction included *
1230 * 2 double diffractive events only *
1232 * what (3) = 1 projectile diffraction treated (2-channel form.) *
1234 * what (4) = alpha-parameter in projectile diffraction *
1236 * what (5..6), sdum no meaning *
1238 *********************************************************************
1241 IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1242 IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1243 IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1245 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/,
1246 & 11X,'IDOUBD is reset to zero')
1249 IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1250 IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1253 *********************************************************************
1255 * control card: codewd = SINGLECH *
1257 * what (1) = 1. Regge contribution (one chain) included *
1259 * what (2..6), sdum no meaning *
1261 *********************************************************************
1265 IF (WHAT(1).EQ.ONE) ISICHA = 1
1268 *********************************************************************
1270 * control card: codewd = NOFRAGME *
1272 * biased chain hadronization *
1274 * what (1..6) = -1 no of hadronizsation of S-S chains *
1275 * = -2 no of hadronizsation of D-S chains *
1276 * = -3 no of hadronizsation of S-D chains *
1277 * = -4 no of hadronizsation of S-V chains *
1278 * = -5 no of hadronizsation of D-V chains *
1279 * = -6 no of hadronizsation of V-S chains *
1280 * = -7 no of hadronizsation of V-D chains *
1281 * = -8 no of hadronizsation of V-V chains *
1282 * = -9 no of hadronizsation of comb. chains *
1283 * default: complete hadronization *
1286 *********************************************************************
1290 ICHAIN = INT(WHAT(I))
1291 IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1292 & LHADRO(ABS(ICHAIN)) = .FALSE.
1296 *********************************************************************
1298 * control card: codewd = HADRONIZE *
1300 * hadronization model and parameter switch *
1302 * what (1) = 1 hadronization via BAMJET *
1303 * = 2 hadronization via JETSET *
1305 * what (2) = 1..3 parameter set to be used *
1306 * JETSET: 3 sets available *
1307 * ( = 3 default JETSET-parameters) *
1308 * BAMJET: 1 set available *
1310 * what (3..6), sdum no meaning *
1312 *********************************************************************
1315 IWHAT1 = INT(WHAT(1))
1316 IWHAT2 = INT(WHAT(2))
1317 IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1318 IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1322 *********************************************************************
1324 * control card: codewd = POPCORN *
1326 * "Popcorn-effect" in fragmentation and diquark breaking diagrams *
1328 * what (1) = (PDB) frac. of diquark fragmenting directly into *
1329 * baryons (PYTHIA/JETSET fragmentation) *
1330 * (JETSET: = 0. Popcorn mechanism switched off) *
1332 * what (2) = probability for accepting a diquark breaking *
1333 * diagram involving the generation of a u/d quark- *
1334 * antiquark pair default: 0.0 *
1335 * what (3) = same a what (2), here for s quark-antiquark pair *
1337 * what (4..6), sdum no meaning *
1339 *********************************************************************
1342 IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1343 IF (WHAT(2).GE.0.0D0) THEN
1347 IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1349 DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1350 DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1351 DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1355 *********************************************************************
1357 * control card: codewd = PARDECAY *
1359 * what (1) = 1. Sigma0/Asigma0 are decaying within JETSET *
1360 * = 2. pion^0 decay after intranucl. cascade *
1361 * default: no decay *
1362 * what (2..6), sdum no meaning *
1364 *********************************************************************
1367 IF (WHAT(1).EQ.ONE) ISIG0 = 1
1368 IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1371 *********************************************************************
1373 * control card: codewd = BEAM *
1375 * definition of beam parameters *
1377 * what (1/2) > 0 : energy of beam 1/2 (GeV) *
1378 * < 0 : abs(what(1/2)) energy per charge of *
1380 * (beam 1 is directed into positive z-direction) *
1381 * what (3) beam crossing angle, defined as 2x angle between *
1382 * one beam and the z-axis (micro rad) *
1383 * what (4) angle with x-axis defining the collision plane *
1384 * what (5..6), sdum no meaning *
1386 * Note: this card requires previously defined projectile and *
1387 * target identities (PROJPAR, TARPAR) *
1389 *********************************************************************
1392 CALL DT_BEAMPR(WHAT,PPN,1)
1398 *********************************************************************
1400 * control card: codewd = LUND-MSTU *
1402 * set parameter MSTU in JETSET-common /LUDAT1/ *
1404 * what (1) = index according to LUND-common block *
1405 * what (2) = new value of MSTU( int(what(1)) ) *
1406 * what (3), what(4) and what (5), what(6) further *
1407 * parameter in the same way as what (1) and *
1409 * default: default-Lund or corresponding to *
1410 * the set given in HADRONIZE *
1412 *********************************************************************
1415 IF (WHAT(1).GT.ZERO) THEN
1417 IMSTU(NMSTU) = INT(WHAT(1))
1418 MSTUX(NMSTU) = INT(WHAT(2))
1420 IF (WHAT(3).GT.ZERO) THEN
1422 IMSTU(NMSTU) = INT(WHAT(3))
1423 MSTUX(NMSTU) = INT(WHAT(4))
1425 IF (WHAT(5).GT.ZERO) THEN
1427 IMSTU(NMSTU) = INT(WHAT(5))
1428 MSTUX(NMSTU) = INT(WHAT(6))
1432 *********************************************************************
1434 * control card: codewd = LUND-MSTJ *
1436 * set parameter MSTJ in JETSET-common /LUDAT1/ *
1438 * what (1) = index according to LUND-common block *
1439 * what (2) = new value of MSTJ( int(what(1)) ) *
1440 * what (3), what(4) and what (5), what(6) further *
1441 * parameter in the same way as what (1) and *
1443 * default: default-Lund or corresponding to *
1444 * the set given in HADRONIZE *
1446 *********************************************************************
1449 IF (WHAT(1).GT.ZERO) THEN
1451 IMSTJ(NMSTJ) = INT(WHAT(1))
1452 MSTJX(NMSTJ) = INT(WHAT(2))
1454 IF (WHAT(3).GT.ZERO) THEN
1456 IMSTJ(NMSTJ) = INT(WHAT(3))
1457 MSTJX(NMSTJ) = INT(WHAT(4))
1459 IF (WHAT(5).GT.ZERO) THEN
1461 IMSTJ(NMSTJ) = INT(WHAT(5))
1462 MSTJX(NMSTJ) = INT(WHAT(6))
1466 *********************************************************************
1468 * control card: codewd = LUND-MDCY *
1470 * set parameter MDCY(I,1) for particle decays in JETSET-common *
1473 * what (1-6) = PDG particle index of particle which should *
1475 * default: default-Lund or forced in *
1478 *********************************************************************
1482 IF (WHAT(I).NE.ZERO) THEN
1483 KC = PYCOMP(INT(WHAT(I)))
1489 *********************************************************************
1491 * control card: codewd = LUND-PARJ *
1493 * set parameter PARJ in JETSET-common /LUDAT1/ *
1495 * what (1) = index according to LUND-common block *
1496 * what (2) = new value of PARJ( int(what(1)) ) *
1497 * what (3), what(4) and what (5), what(6) further *
1498 * parameter in the same way as what (1) and *
1500 * default: default-Lund or corresponding to *
1501 * the set given in HADRONIZE *
1503 *********************************************************************
1506 IF (WHAT(1).NE.ZERO) THEN
1508 IPARJ(NPARJ) = INT(WHAT(1))
1509 PARJX(NPARJ) = WHAT(2)
1511 IF (WHAT(3).NE.ZERO) THEN
1513 IPARJ(NPARJ) = INT(WHAT(3))
1514 PARJX(NPARJ) = WHAT(4)
1516 IF (WHAT(5).NE.ZERO) THEN
1518 IPARJ(NPARJ) = INT(WHAT(5))
1519 PARJX(NPARJ) = WHAT(6)
1523 *********************************************************************
1525 * control card: codewd = LUND-PARU *
1527 * set parameter PARJ in JETSET-common /LUDAT1/ *
1529 * what (1) = index according to LUND-common block *
1530 * what (2) = new value of PARU( int(what(1)) ) *
1531 * what (3), what(4) and what (5), what(6) further *
1532 * parameter in the same way as what (1) and *
1534 * default: default-Lund or corresponding to *
1535 * the set given in HADRONIZE *
1537 *********************************************************************
1540 IF (WHAT(1).GT.ZERO) THEN
1542 IPARU(NPARU) = INT(WHAT(1))
1543 PARUX(NPARU) = WHAT(2)
1545 IF (WHAT(3).GT.ZERO) THEN
1547 IPARU(NPARU) = INT(WHAT(3))
1548 PARUX(NPARU) = WHAT(4)
1550 IF (WHAT(5).GT.ZERO) THEN
1552 IPARU(NPARU) = INT(WHAT(5))
1553 PARUX(NPARU) = WHAT(6)
1557 *********************************************************************
1559 * control card: codewd = OUTLEVEL *
1561 * output control switches *
1563 * what (1) = internal rejection informations default: 0 *
1564 * what (2) = energy-momentum conservation check output *
1566 * what (3) = internal warning messages default: 0 *
1567 * what (4..6), sdum not yet used *
1569 *********************************************************************
1573 IOULEV(K) = INT(WHAT(K))
1577 *********************************************************************
1579 * control card: codewd = FRAME *
1581 * frame in which final state is given in DTEVT1 *
1583 * what (1) = 1 target rest frame (laboratory) *
1584 * = 2 nucleon-nucleon cms *
1587 *********************************************************************
1590 KFRAME = INT(WHAT(1))
1591 IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1594 *********************************************************************
1596 * control card: codewd = L-TAG *
1599 * definition of kinematical cuts for radiated photon and *
1600 * outgoing lepton detection in lepton-nucleus interactions *
1602 * what (1) = y_min *
1603 * what (2) = y_max *
1604 * what (3) = Q^2_min *
1605 * what (4) = Q^2_max *
1606 * what (5) = theta_min (Lab) *
1607 * what (6) = theta_max (Lab) *
1608 * default: no cuts *
1611 *********************************************************************
1622 *********************************************************************
1624 * control card: codewd = L-ETAG *
1627 * what (1) = min. outgoing lepton energy (in Lab) *
1628 * what (2) = min. photon energy (in Lab) *
1629 * what (3) = max. photon energy (in Lab) *
1630 * default: no cuts *
1631 * what (2..6), sdum no meaning *
1633 *********************************************************************
1636 ELMIN = MAX(WHAT(1),ZERO)
1637 EGMIN = MAX(WHAT(2),ZERO)
1638 EGMAX = MAX(WHAT(3),ZERO)
1641 *********************************************************************
1643 * control card: codewd = ECMS-CUT *
1645 * what (1) = min. c.m. energy to be sampled *
1646 * what (2) = max. c.m. energy to be sampled *
1647 * what (3) = min x_Bj to be sampled *
1648 * default: no cuts *
1649 * what (3..6), sdum no meaning *
1651 *********************************************************************
1656 IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1657 XBJMIN = MAX(WHAT(3),ZERO)
1660 *********************************************************************
1662 * control card: codewd = VDM-PAR1 *
1664 * parameters in gamma-nucleus cross section calculation *
1666 * what (1) = Lambda^2 default: 2. *
1667 * what (2) lower limit in M^2 integration *
1670 * = 3 (m_phi)^2 default: 1 *
1671 * what (3) upper limit in M^2 integration *
1674 * = 3 s default: 3 *
1675 * what (4) CKMT F_2 structure function *
1677 * = 100 deuteron default: 2212 *
1678 * what (5) calculation of gamma-nucleon xsections *
1679 * = 1 according to CKMT-parametrization of F_2 *
1680 * = 2 integrating SIGVP over M^2 *
1682 * = 4 PHOJET cross sections default: 4 *
1684 * what (6), sdum no meaning *
1686 *********************************************************************
1689 IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1690 IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1691 IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1692 IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1693 IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1696 *********************************************************************
1698 * control card: codewd = HISTOGRAM *
1700 * activate different classes of histograms *
1702 * default: no histograms *
1704 *********************************************************************
1708 IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1709 IHISPP(INT(WHAT(J))-100) = 1
1710 ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1711 IHISXS(INT(ABS(WHAT(J)))-200) = 1
1712 IF (WHAT(J).LT.ZERO) IXSTBL = 1
1717 *********************************************************************
1719 * control card: codewd = XS-TABLE *
1721 * output of cross section table for requested interaction *
1722 * - particle production deactivated ! - *
1724 * what (1) lower energy limit for tabulation *
1726 * < 0 nucleon-nucleon cms *
1727 * what (2) upper energy limit for tabulation *
1729 * < 0 nucleon-nucleon cms *
1730 * what (3) > 0 # of equidistant lin. bins in E *
1731 * < 0 # of equidistant log. bins in E *
1732 * what (4) lower limit of particle virtuality (photons) *
1733 * what (5) upper limit of particle virtuality (photons) *
1734 * what (6) > 0 # of equidistant lin. bins in Q^2 *
1735 * < 0 # of equidistant log. bins in Q^2 *
1737 *********************************************************************
1740 IF (WHAT(1).EQ.99999.0D0) THEN
1741 IRATIO = INT(WHAT(2))
1744 CMENER = ABS(WHAT(2))
1745 IF (.NOT.LXSTAB) THEN
1749 IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1751 IF (WHAT(2).GT.ZERO)
1752 & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1755 C WRITE(LOUT,*) 'CMENER = ',CMENER
1756 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1759 CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1764 *********************************************************************
1766 * control card: codewd = GLAUB-PAR *
1768 * parameters in Glauber-formalism *
1770 * what (1) # of nucleon configurations sampled in integration *
1771 * over nuclear desity default: 1000 *
1772 * what (2) # of bins for integration over impact-parameter and *
1773 * for profile-function calculation default: 49 *
1774 * what (3) = 1 calculation of tot., el. and qel. cross sections *
1776 * what (4) = 1 read pre-calculated impact-parameter distrib. *
1778 * =-1 dump pre-calculated impact-parameter distrib. *
1780 * = 100 read pre-calculated impact-parameter distrib. *
1781 * for variable projectile/target/energy runs *
1784 * what (5..6) no meaning *
1785 * sdum if |what (4)| = 1 name of in/output-file (sdum.glb) *
1787 *********************************************************************
1790 IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1791 IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1792 IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1793 IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1794 IOGLB = INT(WHAT(4))
1799 *********************************************************************
1801 * control card: codewd = GLAUB-INI *
1803 * pre-initialization of profile function *
1805 * what (1) lower energy limit for initialization *
1807 * < 0 nucleon-nucleon cms *
1808 * what (2) upper energy limit for initialization *
1810 * < 0 nucleon-nucleon cms *
1811 * what (3) > 0 # of equidistant lin. bins in E *
1812 * < 0 # of equidistant log. bins in E *
1813 * what (4) maximum projectile mass number for which the *
1814 * Glauber data are initialized for each *
1815 * projectile mass number *
1816 * (if <= mass given with the PROJPAR-card) *
1818 * what (5) steps in mass number starting from what (4) *
1819 * up to mass number defined with PROJPAR-card *
1820 * for which Glauber data are initialized *
1822 * what (6) no meaning *
1825 *********************************************************************
1829 CALL DT_GLBINI(WHAT)
1832 *********************************************************************
1834 * control card: codewd = VDM-PAR2 *
1836 * parameters in gamma-nucleus cross section calculation *
1838 * what (1) = 0 no suppression of shadowing by direct photon *
1840 * = 1 suppression .. default: 1 *
1841 * what (2) = 0 no suppression of shadowing by anomalous *
1842 * component if photon-F_2 *
1843 * = 1 suppression .. default: 1 *
1844 * what (3) = 0 no suppression of shadowing by coherence *
1845 * length of the photon *
1846 * = 1 suppression .. default: 1 *
1847 * what (4) = 1 longitudinal polarized photons are taken into *
1849 * eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 *
1850 * what (5..6), sdum no meaning *
1852 *********************************************************************
1855 IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
1856 IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
1857 IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
1861 *********************************************************************
1863 * control card: XS-QELPRO *
1865 * what (1..6), sdum no meaning *
1867 *********************************************************************
1870 IXSQEL = ABS(WHAT(1))
1873 *********************************************************************
1875 * control card: RNDMINIT *
1877 * initialization of random number generator *
1879 * what (1..4) values for initialization (= 1..168) *
1880 * what (5..6), sdum no meaning *
1882 *********************************************************************
1885 IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
1890 IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
1895 IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
1900 IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
1905 CALL DT_RNDMST(NA1,NA2,NA3,NA4)
1908 *********************************************************************
1910 * control card: codewd = LEPTO-CUT *
1912 * set parameter CUT in LEPTO-common /LEPTOU/ *
1914 * what (1) = index in CUT-array *
1915 * what (2) = new value of CUT( int(what(1)) ) *
1916 * what (3), what(4) and what (5), what(6) further *
1917 * parameter in the same way as what (1) and *
1919 * default: default-LEPTO parameters *
1921 *********************************************************************
1924 IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
1925 IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
1926 IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
1929 *********************************************************************
1931 * control card: codewd = LEPTO-LST *
1933 * set parameter LST in LEPTO-common /LEPTOU/ *
1935 * what (1) = index in LST-array *
1936 * what (2) = new value of LST( int(what(1)) ) *
1937 * what (3), what(4) and what (5), what(6) further *
1938 * parameter in the same way as what (1) and *
1940 * default: default-LEPTO parameters *
1942 *********************************************************************
1945 IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
1946 IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
1947 IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
1950 *********************************************************************
1952 * control card: codewd = LEPTO-PARL *
1954 * set parameter PARL in LEPTO-common /LEPTOU/ *
1956 * what (1) = index in PARL-array *
1957 * what (2) = new value of PARL( int(what(1)) ) *
1958 * what (3), what(4) and what (5), what(6) further *
1959 * parameter in the same way as what (1) and *
1961 * default: default-LEPTO parameters *
1963 *********************************************************************
1966 IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
1967 IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
1968 IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
1971 *********************************************************************
1973 * control card: codewd = START *
1975 * what (1) = number of events default: 100. *
1976 * what (2) = 0 Glauber initialization follows *
1977 * = 1 Glauber initialization supressed, fitted *
1978 * results are used instead *
1979 * (this does not apply if emulsion-treatment *
1981 * = 2 Glauber initialization is written to *
1982 * output-file shmakov.out *
1983 * = 3 Glauber initialization is read from input-file *
1984 * shmakov.out default: 0 *
1985 * what (3..6) no meaning *
1986 * what (3..6) no meaning *
1988 *********************************************************************
1992 * check for cross-section table output only
1995 NCASES = INT(WHAT(1))
1996 IF (NCASES.LE.0) NCASES = 100
1997 IGLAU = INT(WHAT(2))
1998 IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
2007 IF (IDP.LE.0) IDP = 1
2008 * muon neutrinos: temporary (missing index)
2009 * (new patch in projpar: therefore the following this is probably not
2010 * necessary anymore..)
2011 C IF (IDP.EQ.26) IDP = 5
2012 C IF (IDP.EQ.27) IDP = 6
2014 * redefine collision energy
2016 IF (ABS(VAREHI).GT.ZERO) THEN
2018 IF (VARELO.LT.EHADLO) VARELO = EHADLO
2019 CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2021 CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2023 CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2026 1003 FORMAT(1X,'INIT: collision energy not defined!',/,
2027 & 1X,' -program stopped- ')
2031 * switch off evaporation (even if requested) if central coll. requ.
2032 IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2035 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since',
2036 & ' central collisions forced.')
2043 * initialization of evaporation-module
2046 1010 FORMAT(1X,/,'Warning! No evaporation performed since',
2047 & ' evaporation modules not available with this version.')
2057 * save the default JETSET-parameter
2060 * force use of phojet for g-A
2061 IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2062 * initialization of nucleon-nucleon event generator
2063 IF (MCGENE.EQ.2) CALL DT_PHOINI
2064 * initialization of LEPTO event generator
2065 IF (MCGENE.EQ.3) THEN
2067 STOP ' This version does not contain LEPTO !'
2071 * initialization of quasi-elastic neutrino scattering
2072 IF (MCGENE.EQ.4) THEN
2073 IF (IJPROJ.EQ.5) THEN
2075 ELSEIF (IJPROJ.EQ.6) THEN
2077 ELSEIF (IJPROJ.EQ.135) THEN
2079 ELSEIF (IJPROJ.EQ.136) THEN
2081 ELSEIF (IJPROJ.EQ.133) THEN
2083 ELSEIF (IJPROJ.EQ.134) THEN
2088 * normalize fractions of emulsion components
2089 IF (NCOMPO.GT.0) THEN
2092 SUMFRA = SUMFRA+EMUFRA(I)
2094 IF (SUMFRA.GT.ZERO) THEN
2096 EMUFRA(I) = EMUFRA(I)/SUMFRA
2101 * disallow Cronin's multiple scattering for nucleus-nucleus interactions
2102 IF ((IP.GT.1).AND. (IT.GT.1) .AND. (MKCRON.GT.0)) THEN
2104 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/)
2108 * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2109 C IF (NCOMPO.LE.0) THEN
2110 C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2113 C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2117 * pre-tabulation of elastic cross-sections
2118 CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2124 *********************************************************************
2126 * control card: codewd = STOP *
2128 * stop of the event generation *
2130 * what (1..6) no meaning *
2132 *********************************************************************
2136 9000 FORMAT(1X,'---> unexpected end of input !')
2143 *$ CREATE DT_KKINC.FOR
2146 *===kkinc==============================================================*
2148 SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2151 ************************************************************************
2152 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
2153 * This subroutine is an update of the previous version written *
2154 * by J. Ranft/ H.-J. Moehring. *
2155 * This version dated 19.11.95 is written by S. Roesler *
2156 ************************************************************************
2158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2160 PARAMETER ( LINP = 10 ,
2163 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2164 & TINY2=1.0D-2,TINY3=1.0D-3)
2170 PARAMETER (NMXHEP=4000)
2171 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2172 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2173 & VHEP(4,NMXHEP), NSD1, NSD2, NDD
2175 PARAMETER (NMXHKK=200000)
2176 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2177 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2178 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2179 * extended event history
2180 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2181 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2183 * particle properties (BAMJET index convention)
2185 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2186 & IICH(210),IIBAR(210),K1(210),K2(210)
2187 * properties of interacting particles
2188 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2189 * Lorentz-parameters of the current interaction
2190 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2191 & UMO,PPCM,EPROJ,PPROJ
2192 * flags for input different options
2193 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2194 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2195 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2196 * flags for particle decays
2197 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2198 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2199 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2200 * cuts for variable energy runs
2201 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2202 * Glauber formalism: flags and parameters for statistics
2205 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
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.
3363 & (ABS(ISTHKK(I)).EQ.2) .OR.
3364 & (ISTHKK(I).EQ.1000) .OR.
3365 & (ISTHKK(I).EQ.1001)) THEN
3367 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3368 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3370 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3371 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3381 *$ CREATE DT_REJUCO.FOR
3384 *===rejuco=============================================================*
3386 SUBROUTINE DT_REJUCO(MODE,IREJ)
3388 ************************************************************************
3389 * REJection of Unphysical COnfigurations *
3390 * MODE = 1 rejection of particles with unphysically large energy *
3392 * This version dated 27.12.2006 is written by S. Roesler. *
3393 ************************************************************************
3395 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3398 PARAMETER ( LINP = 10 ,
3401 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3402 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3404 * maximum x_cms of final state particle
3405 PARAMETER (XCMSMX = 1.4D0)
3408 PARAMETER (NMXHKK=200000)
3409 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3410 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3411 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3412 * extended event history
3413 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3414 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3416 * Lorentz-parameters of the current interaction
3417 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3418 & UMO,PPCM,EPROJ,PPROJ
3423 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3425 DO 10 I=NPOINT(4),NHKK
3426 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3427 XCMS = ABS(PHKK(4,I))/ECMHLF
3428 IF (XCMS.GT.XCMSMX) GOTO 9999
3439 *$ CREATE DT_EVENTB.FOR
3442 *===eventb=============================================================*
3444 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3446 ************************************************************************
3447 * Treatment of nucleon-nucleon interactions with full two-component *
3448 * Dual Parton Model. *
3449 * NCSY number of nucleon-nucleon interactions *
3450 * IREJ rejection flag *
3451 * This version dated 14.01.2000 is written by S. Roesler *
3452 ************************************************************************
3454 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3456 PARAMETER ( LINP = 10 ,
3459 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3462 PARAMETER (NMXHKK=200000)
3463 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3464 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3465 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3466 * extended event history
3467 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3468 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3470 *! uncomment this line for internal phojet-fragmentation
3471 C #include "dtu_dtevtp.inc"
3472 * particle properties (BAMJET index convention)
3474 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3475 & IICH(210),IIBAR(210),K1(210),K2(210)
3476 * flags for input different options
3477 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3478 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3479 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3481 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3482 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3483 & IREXCI(3),IRDIFF(2),IRINC
3484 * properties of interacting particles
3485 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3486 * properties of photon/lepton projectiles
3487 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3488 * various options for treatment of partons (DTUNUC 1.x)
3489 * (chain recombination, Cronin,..)
3490 LOGICAL LCO2CR,LINTPT
3491 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3494 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3495 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3497 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3498 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3499 * Glauber formalism: collision properties
3500 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3501 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3502 * flags for diffractive interactions (DTUNUC 1.x)
3503 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3504 * statistics: double-Pomeron exchange
3505 COMMON /DTFLG2/ INTFLG,IPOPO
3506 * flags for particle decays
3507 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3508 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3509 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3510 * nucleon-nucleon event-generator
3513 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3514 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3515 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3516 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3517 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3518 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3519 C model switches and parameters
3521 INTEGER ISWMDL,IPAMDL
3522 DOUBLE PRECISION PARMDL
3523 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3524 C initial state parton radiation (internal part)
3525 INTEGER MXISR3,MXISR4
3526 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3527 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3528 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3529 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3530 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3531 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3532 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3533 C event debugging information
3535 PARAMETER (NMAXD=100)
3536 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3537 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3538 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3539 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3540 C general process information
3541 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3542 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3544 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3545 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3546 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3547 & KPRON(15),ISINGL(2000)
3549 * initial values for max. number of phojet scatterings and dtunuc chains
3550 * to be fragmented with one pyexec call
3551 DATA MXPHFR,MXDTFR /10,100/
3554 * pointer to first parton of the first chain in dtevt common
3556 * special flag for double-Pomeron statistics
3558 * counter for low-mass (DTUNUC) interactions
3560 * counter for interactions treated by PHOJET
3563 * scan interactions for single nucleon-nucleon interactions
3564 * (this has to be checked here because Cronin modifies parton momenta)
3566 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3570 MOT = JMOHKK(1,NC+1)
3571 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3572 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3573 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3577 * multiple scattering of chain ends
3578 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3579 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3581 * switch to PHOJET-settings for JETSET parameter
3584 * loop over nucleon-nucleon interaction
3588 * pick up one nucleon-nucleon interaction from DTEVT1
3589 * ppnn / ptnn - momenta of the interacting nucleons (cms)
3590 * ptotnn - total momentum of the interacting nucleons (cms)
3591 * pp1,2 / pt1,2 - momenta of the four partons
3592 * pp / pt - total momenta of the proj / targ partons
3593 * ptot - total momentum of the four partons
3595 MOT = JMOHKK(1,NC+1)
3597 PPNN(K) = PHKK(K,MOP)
3598 PTNN(K) = PHKK(K,MOT)
3599 PTOTNN(K) = PPNN(K)+PTNN(K)
3601 PT1(K) = PHKK(K,NC+1)
3602 PP2(K) = PHKK(K,NC+2)
3603 PT2(K) = PHKK(K,NC+3)
3604 PP(K) = PP1(K)+PP2(K)
3605 PT(K) = PT1(K)+PT2(K)
3606 PTOT(K) = PP(K)+PT(K)
3609 *-----------------------------------------------------------------------
3610 * this is a complete nucleon-nucleon interaction
3612 IF (ISINGL(I).EQ.1) THEN
3614 * initialize PHOJET-variables for remnant/valence-partons
3621 * save current settings of PHOJET process and min. bias flags
3623 KPRON(K) = IPRON(K,1)
3627 * check if forced sampling of diffractive interaction requested
3628 IF (ISINGD.LT.-1) THEN
3632 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3633 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3634 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3637 * for photons: a direct/anomalous interaction is not sampled
3638 * in PHOJET but already in Glauber-formalism. Here we check if such
3639 * an interaction is requested
3640 IF (IJPROJ.EQ.7) THEN
3641 * first switch off direct interactions
3643 * this is a direct interactions
3644 IF (IDIREC.EQ.1) THEN
3649 * this is an anomalous interactions
3650 * (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3651 ELSEIF (IDIREC.EQ.2) THEN
3655 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3658 * make sure that total momenta of partons, pp and pt, are on mass
3659 * shell (Cronin may have srewed this up..)
3660 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3662 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3663 & 'EVENTB: mass shell correction rejected'
3667 * initialize the incoming particles in PHOJET
3668 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3669 CALL PHO_SETPAR(1,22,0,VIRT)
3671 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3673 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3675 * initialize rejection loop counter for anomalous processes
3680 * temporary fix for ifano problem
3684 * generate complete hadron/nucleon/photon-nucleon event with PHOJET
3685 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3687 * for photons: special consistency check for anomalous interactions
3688 IF (IJPROJ.EQ.7) THEN
3689 IF (IRJANO.LT.30) THEN
3690 IF (IFANO(1).NE.0) THEN
3691 * here, an anomalous interaction was generated. Check if it
3692 * was also requested. Otherwise reject this event.
3693 IF (IDIREC.EQ.0) GOTO 800
3695 * here, an anomalous interaction was not generated. Check if it
3696 * was requested in which case we need to reject this event.
3697 IF (IDIREC.EQ.2) GOTO 800
3700 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3701 & IRJANO,IDIREC,NEVHKK
3705 * copy back original settings of PHOJET process and min. bias flags
3707 IPRON(K,1) = KPRON(K)
3711 * check if PHOJET has rejected this event
3712 IF (IREJ1.NE.0) THEN
3713 C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3714 WRITE(LOUT,'(1X,A,I4)')
3715 & 'EVENTB: chain system rejected',IDIREC
3720 * copy partons and strings from PHOJET common back into DTEVT for
3721 * external fragmentation
3724 *! uncomment this line for internal phojet-fragmentation
3725 C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3727 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3728 IF (IREJ1.NE.0) THEN
3730 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3734 * update statistics counter
3735 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3737 *-----------------------------------------------------------------------
3738 * this interaction involves "remnants"
3742 * total mass of this system
3743 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3744 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3745 IF (AMTOT2.LT.ZERO) THEN
3748 AMTOT = SQRT(AMTOT2)
3751 * systems with masses larger than elojet are treated with PHOJET
3752 IF (AMTOT.GT.ELOJET) THEN
3754 * initialize PHOJET-variables for remnant/valence-partons
3755 * projectile parton flavors and valence flag
3756 IHFLD(1,1) = IDHKK(NC)
3757 IHFLD(1,2) = IDHKK(NC+2)
3759 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3760 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3761 * target parton flavors and valence flag
3762 IHFLD(2,1) = IDHKK(NC+1)
3763 IHFLD(2,2) = IDHKK(NC+3)
3765 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3766 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3767 * flag signalizing PHOJET how to treat the remnant:
3768 * iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3769 * iremn > -1 valence remnant: PHOJET assumes flavors according
3770 * to mother particle
3774 * initialize the incoming particles in PHOJET
3775 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3776 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3778 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3780 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3782 * calculate Lorentz parameter of the nucleon-nucleon cm-system
3783 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3784 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3785 BGX = PTOTNN(1)/AMNN
3786 BGY = PTOTNN(2)/AMNN
3787 BGZ = PTOTNN(3)/AMNN
3788 GAM = PTOTNN(4)/AMNN
3789 * transform interacting nucleons into nucleon-nucleon cm-system
3790 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3791 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3792 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3793 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3794 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3795 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3796 * transform (total) momenta of the proj and targ partons into
3797 * nucleon-nucleon cm-system
3798 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3799 & PP(1),PP(2),PP(3),PP(4),
3800 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3801 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3802 & PT(1),PT(2),PT(3),PT(4),
3803 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3804 * energy fractions of the proj and targ partons
3805 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3806 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3809 c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3810 c & (PPTCMS(2)+PTTCMS(2))**2 +
3811 c & (PPTCMS(3)+PTTCMS(3))**2 )
3812 c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3813 c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3814 c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3815 c & (PPSUB(2)+PTSUB(2))**2 +
3816 c & (PPSUB(3)+PTSUB(3))**2 )
3817 c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3818 c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3821 * save current settings of PHOJET process and min. bias flags
3823 KPRON(K) = IPRON(K,1)
3825 * disallow direct photon int. (does not make sense here anyway)
3827 * disallow double pomeron processes (due to technical problems
3828 * in PHOJET, needs to be solved sometime)
3830 * disallow diffraction for sea-diquarks
3831 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3832 & (IABS(IHFLD(1,2)).GT.1100)) THEN
3836 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3837 & (IABS(IHFLD(2,2)).GT.1100)) THEN
3842 * we need massless partons: transform them on mass shell
3849 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3850 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3851 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3852 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3853 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3854 * total energy of the subsysten after mass transformation
3855 * (should be the same as before..)
3856 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3857 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
3859 * after mass shell transformation the x_sub - relation has to be
3860 * corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3862 * The old version was to scale based on the original x_sub and the
3863 * 4-momenta of the subsystem. At very high energy this could lead to
3864 * "pseudo-cm energies" of the parent system considerably exceeding
3865 * the true cm energy. Now we keep the true cm energy and calculate
3866 * new x_sub instead.
3867 C old version PPTCMS(4) = PPSUB(4)/XPSUB
3868 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3869 XPSUB = PPSUB(4)/PPTCMS(4)
3870 IF (IJPROJ.EQ.7) THEN
3871 AMP2 = PHKK(5,MOT)**2
3872 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3875 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3876 & *(PPTCMS(4)+PHKK(5,MOP)))
3877 C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3878 C & *(PPTCMS(4)+PHKK(5,MOT)))
3880 C old version PTTCMS(4) = PTSUB(4)/XTSUB
3881 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3882 XTSUB = PTSUB(4)/PTTCMS(4)
3883 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3884 & *(PTTCMS(4)+PHKK(5,MOT)))
3886 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3887 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3892 * ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
3893 * ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
3894 * pptcms/ pttcms - momenta of the interacting nucleons (cms)
3895 * pp1,2 / pt1,2 - momenta of the four partons
3897 * pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
3898 * ptot - total momentum of the four partons (cms, negl. Fermi)
3899 * ppsub / ptsub - total momenta of the proj / targ partons (cms)
3901 c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3902 c & (PPTCMS(2)+PTTCMS(2))**2 +
3903 c & (PPTCMS(3)+PTTCMS(3))**2 )
3904 c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3905 c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3906 c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3907 c & (PPSUB(2)+PTSUB(2))**2 +
3908 c & (PPSUB(3)+PTSUB(3))**2 )
3909 c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3910 c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3911 c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3912 c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3913 c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3914 c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
3916 c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3917 c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3918 c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3919 c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3920 * transform interacting nucleons into nucleon-nucleon cm-system
3921 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3922 c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3923 c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3924 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3925 c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3926 c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3927 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3928 c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3929 c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3930 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3931 c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3932 c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3933 c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3934 c & (PPNEW2+PTNEW2)**2 +
3935 c & (PPNEW3+PTNEW3)**2 )
3936 c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3937 c & (PPNEW4+PTNEW4+PTSTCM) )
3938 c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3939 c & (PPSUB2+PTSUB2)**2 +
3940 c & (PPSUB3+PTSUB3)**2 )
3941 c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3942 c & (PPSUB4+PTSUB4+PTSTSU) )
3943 C WRITE(*,*) ' mother cmE :'
3944 C WRITE(*,*) ETSTCM,ENEWCM
3945 C WRITE(*,*) ' subsystem cmE :'
3946 C WRITE(*,*) ETSTSU,ENEWSU
3947 C WRITE(*,*) ' projectile mother :'
3948 C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3949 C WRITE(*,*) ' target mother :'
3950 C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3951 C WRITE(*,*) ' projectile subsystem:'
3952 C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3953 C WRITE(*,*) ' target subsystem:'
3954 C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3955 C WRITE(*,*) ' projectile subsystem should be:'
3956 C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3957 C & XPSUB*ETSTCM/2.0D0
3958 C WRITE(*,*) ' target subsystem should be:'
3959 C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3960 C & XTSUB*ETSTCM/2.0D0
3961 C WRITE(*,*) ' subsystem cmE should be: '
3962 C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3965 * generate complete remnant - nucleon/remnant event with PHOJET
3966 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3968 * copy back original settings of PHOJET process flags
3970 IPRON(K,1) = KPRON(K)
3973 * check if PHOJET has rejected this event
3974 IF (IREJ1.NE.0) THEN
3976 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
3978 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3983 * copy partons and strings from PHOJET common back into DTEVT for
3984 * external fragmentation
3987 *! uncomment this line for internal phojet-fragmentation
3988 C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3990 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3991 IF (IREJ1.NE.0) THEN
3992 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3993 & 'EVENTB: chain system rejected 2'
3997 * update statistics counter
3998 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4000 *-----------------------------------------------------------------------
4001 * two-chain approx. for smaller systems
4006 * special flag for double-Pomeron statistics
4009 * pick up flavors at the ends of the two chains
4014 * ..and the indices of the mothers
4019 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4020 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4022 * check if this chain system was rejected
4023 IF (IREJ1.GT.0) THEN
4024 IF (IOULEV(1).GT.0) THEN
4025 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4026 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4027 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4032 * the following lines are for sea-sea chains rejected in GETCSY
4033 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4034 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4039 * update statistics counter
4040 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4046 *-----------------------------------------------------------------------
4047 * treatment of low-mass chains (if there are any)
4049 IF (NDTUSC.GT.0) THEN
4051 * correct chains of very low masses for possible resonances
4052 IF (IRESCO.EQ.1) THEN
4053 CALL DT_EVTRES(IREJ1)
4054 IF (IREJ1.GT.0) THEN
4055 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4056 IRRES(1) = IRRES(1)+1
4060 * fragmentation of low-mass chains
4061 *! uncomment this line for internal phojet-fragmentation
4062 * (of course it will still be fragmented by DPMJET-routines but it
4063 * has to be done here instead of further below)
4064 C CALL DT_EVTFRA(IREJ1)
4065 C IF (IREJ1.GT.0) THEN
4066 C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4071 *! uncomment this line for internal phojet-fragmentation
4072 C NPOINT(4) = NHKK+1
4073 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4076 *-----------------------------------------------------------------------
4077 * new di-quark breaking mechanisms
4081 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4082 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4087 *-----------------------------------------------------------------------
4088 * hadronize this event
4090 * hadronize PHOJET chain systems
4092 NPJE = NPHOSC/MXPHFR
4093 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4095 NLEFT = NPHOSC-NPJE*MXPHFR
4098 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4099 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4100 IF (IREJ1.GT.0) GOTO 22
4103 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4104 IF (IREJ1.GT.0) GOTO 22
4106 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4108 IF (NLEFT.GT.0) THEN
4109 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4110 IF (IREJ1.GT.0) GOTO 22
4111 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4114 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4115 IF (IREJ1.GT.0) GOTO 22
4116 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4119 * check max. filling level of jetset common and
4120 * reduce mxphfr if necessary
4121 IF (NPYMAX.GT.3000) THEN
4122 IF (NPYMAX.GT.3500) THEN
4123 MXPHFR = MAX(1,MXPHFR-2)
4125 MXPHFR = MAX(1,MXPHFR-1)
4127 C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4130 * hadronize DTUNUC chain systems
4133 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4134 IF (IREJ2.GT.0) GOTO 22
4136 * check max. filling level of jetset common and
4137 * reduce mxdtfr if necessary
4138 IF (NPYMEM.GT.3000) THEN
4139 IF (NPYMEM.GT.3500) THEN
4140 MXDTFR = MAX(1,MXDTFR-20)
4142 MXDTFR = MAX(1,MXDTFR-10)
4144 C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4147 IF (IBACK.EQ.-1) GOTO 23
4150 C CALL DT_EVTFRG(1,IREJ1)
4151 C CALL DT_EVTFRG(2,IREJ2)
4152 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4153 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4158 * get final state particles from /DTEVTP/
4159 *! uncomment this line for internal phojet-fragmentation
4160 C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4163 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4164 C IF (IREJ3.NE.0) GOTO 9999
4174 *$ CREATE DT_GETPJE.FOR
4177 *===getpje=============================================================*
4179 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4181 ************************************************************************
4182 * This subroutine copies PHOJET partons and strings from POEVT1 into *
4184 * MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4185 * PP,PT 4-momenta of projectile/target being handled by *
4187 * This version dated 11.12.99 is written by S. Roesler *
4188 ************************************************************************
4190 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4192 PARAMETER ( LINP = 10 ,
4195 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4196 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4201 PARAMETER (NMXHKK=200000)
4202 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4203 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4204 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4205 * extended event history
4206 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4207 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4209 * Lorentz-parameters of the current interaction
4210 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4211 & UMO,PPCM,EPROJ,PPROJ
4212 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4213 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4214 * flags for input different options
4215 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4216 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4217 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4218 * statistics: double-Pomeron exchange
4219 COMMON /DTFLG2/ INTFLG,IPOPO
4221 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4222 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4225 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4226 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4227 & IREXCI(3),IRDIFF(2),IRINC
4228 C standard particle data interface
4230 PARAMETER (NMXHEP=4000)
4231 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4232 DOUBLE PRECISION PHEP,VHEP
4233 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4234 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4235 & VHEP(4,NMXHEP), NSD1, NSD2, NDD
4236 C extension to standard particle data interface (PHOJET specific)
4237 INTEGER IMPART,IPHIST,ICOLOR
4238 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4239 C color string configurations including collapsed strings and hadrons
4241 PARAMETER (MSTR=500)
4242 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4243 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4244 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4245 & NNCH(MSTR),IBHAD(MSTR),ISTR
4246 C general process information
4247 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4248 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4249 C model switches and parameters
4251 INTEGER ISWMDL,IPAMDL
4252 DOUBLE PRECISION PARMDL
4253 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4254 C event debugging information
4256 PARAMETER (NMAXD=100)
4257 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4258 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4259 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4260 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4262 DIMENSION PP(4),PT(4)
4272 * store initial momenta for energy-momentum conservation check
4274 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4275 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4277 * copy partons and strings from POEVT1 into DTEVT1
4279 C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4280 IF (NCODE(I).EQ.-99) THEN
4282 IDSTG = IDHEP(IDXSTG)
4289 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4296 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4299 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4302 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4309 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4313 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4315 ELSEIF (NCODE(I).GE.0) THEN
4316 * indices of partons and string in POEVT1
4317 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4318 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4319 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4320 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4321 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4325 * find "mother" string of the string
4326 IDXMS1 = ABS(JMOHEP(1,IDX1))
4327 IDXMS2 = ABS(JMOHEP(1,IDX2))
4328 IF (IDXMS1.NE.IDXMS2) THEN
4331 C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4333 * search POEVT1 for the original hadron of the parton
4338 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4339 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4340 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4341 & (ILOOP.LT.MAXLOP)) GOTO 14
4342 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4347 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4348 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4349 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4351 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4353 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4354 & (ILOOP.LT.MAXLOP)) GOTO 15
4355 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4357 IF (IDXMS1.EQ.1) THEN
4358 ISPTN1 = ISTHKK(MO1)
4362 ISPTN1 = ISTHKK(MO2)
4367 IF (IDXMS2.EQ.1) THEN
4368 ISPTN2 = ISTHKK(MO1)
4372 ISPTN2 = ISTHKK(MO2)
4376 * check for mis-identified mothers and switch mother indices if necessary
4377 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4378 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4380 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4381 ISPTN1 = ISTHKK(MO1)
4384 ISPTN2 = ISTHKK(MO2)
4388 ISPTN1 = ISTHKK(MO2)
4391 ISPTN2 = ISTHKK(MO1)
4396 * register partons in temporary common
4397 * parton at chain end
4402 * flag only partons coming from Pomeron with 41/42
4403 C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4404 IF (IPOM1.NE.0) THEN
4405 ISTX = ABS(ISPTN1)/10
4406 IMO = ABS(ISPTN1)-10*ISTX
4409 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4410 ISTX = ABS(ISPTN1)/10
4411 IMO = ABS(ISPTN1)-10*ISTX
4412 IF ((IDHEP(IDX1).EQ.21).OR.
4413 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4420 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4421 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4423 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4426 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4428 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4431 IHIST(1,NHKK) = IPHIST(1,IDX1)
4434 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4435 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4437 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4438 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4441 NGLUON = IDX2-IDX1-1
4442 IF (NGLUON.GT.0) THEN
4443 DO 17 IGLUON=1,NGLUON
4445 IDXMS = ABS(JMOHEP(1,IDX))
4446 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4450 IDXMS = ABS(JMOHEP(1,IDXMS))
4451 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4452 & (ILOOP.LT.MAXLOP)) GOTO 16
4453 IF (ILOOP.EQ.MAXLOP)
4454 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4456 IF (IDXMS.EQ.1) THEN
4469 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4470 ISTX = ABS(ISPTN)/10
4471 IMO = ABS(ISPTN)-10*ISTX
4472 IF ((IDHEP(IDX).EQ.21).OR.
4473 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4479 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4480 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4482 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4483 & PX,PY,PZ,PE,0,0,0)
4485 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4487 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4488 & PPX,PPY,PPZ,PPE,0,0,0)
4490 IHIST(1,NHKK) = IPHIST(1,IDX)
4493 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4494 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4496 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4497 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4500 * parton at chain end
4505 * flag only partons coming from Pomeron with 41/42
4506 C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4507 IF (IPOM2.NE.0) THEN
4508 ISTX = ABS(ISPTN2)/10
4509 IMO = ABS(ISPTN2)-10*ISTX
4512 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4513 ISTX = ABS(ISPTN2)/10
4514 IMO = ABS(ISPTN2)-10*ISTX
4515 IF ((IDHEP(IDX2).EQ.21).OR.
4516 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4523 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4524 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4526 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4527 & PX,PY,PZ,PE,0,0,0)
4529 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4531 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4532 & PPX,PPY,PPZ,PPE,0,0,0)
4534 IHIST(1,NHKK) = IPHIST(1,IDX2)
4537 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4538 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4540 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4541 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4544 JSTRG = 100*IPROCE+NCODE(I)
4551 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4552 & PX,PY,PZ,PE,0,0,0)
4558 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4561 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4564 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4565 & PPX,PPY,PPZ,PPE,0,0,0)
4571 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4578 VHKK(KK,NHKK) = VHKK(KK,MO2)
4579 WHKK(KK,NHKK) = WHKK(KK,MO1)
4581 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4582 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4586 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4593 IF (UMO.GT.1.0D5) THEN
4598 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4599 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4602 * internal statistics
4603 * dble-Po statistics.
4604 IF (IPROCE.NE.4) IPOPO = 0
4608 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4609 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4611 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4612 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4613 & ') at evt(chain) ',I6,'(',I2,')')
4615 IF (IPROCE.EQ.5) THEN
4616 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4617 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4619 C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4620 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4621 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4623 ELSEIF (IPROCE.EQ.6) THEN
4624 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4625 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4627 C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4629 ELSEIF (IPROCE.EQ.7) THEN
4630 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4631 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4632 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4633 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4634 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4635 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4636 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4637 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4638 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4639 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4641 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4644 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4646 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4647 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4648 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4650 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4651 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4652 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4653 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4654 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4663 *$ CREATE DT_PHOINI.FOR
4666 *===phoini=============================================================*
4668 SUBROUTINE DT_PHOINI
4670 ************************************************************************
4671 * Initialization PHOJET-event generator for nucleon-nucleon interact. *
4672 * This version dated 16.11.95 is written by S. Roesler *
4674 * Last change 27.12.2006 by S. Roesler. *
4675 ************************************************************************
4677 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4679 PARAMETER ( LINP = 10 ,
4682 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4684 * nucleon-nucleon event-generator
4687 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4688 * particle properties (BAMJET index convention)
4690 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4691 & IICH(210),IIBAR(210),K1(210),K2(210)
4692 * Lorentz-parameters of the current interaction
4693 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4694 & UMO,PPCM,EPROJ,PPROJ
4695 * properties of interacting particles
4696 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4697 * properties of photon/lepton projectiles
4698 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4699 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4700 * emulsion treatment
4701 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4703 * VDM parameter for photon-nucleus interactions
4704 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4707 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4708 & EBINDP(2),EBINDN(2),EPOT(2,210),
4709 & ETACOU(2),ICOUL,LFERMI
4710 * Glauber formalism: flags and parameters for statistics
4713 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4715 * parameters for cascade calculations:
4716 * maximum mumber of PDF's which can be defined in phojet (limited
4717 * by the dimension of ipdfs in pho_setpdf)
4718 PARAMETER (MAXPDF = 20)
4719 * PDF parametrization and number of set for the first 30 hadrons in
4720 * the bamjet-code list
4721 * negative numbers mean that the PDF is set in phojet,
4722 * zero stands for "not a hadron"
4723 DIMENSION IPARPD(30),ISETPD(30)
4724 * PDF parametrization
4726 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4727 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4730 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4731 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4734 C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4735 C PARAMETER ( MAXPRO = 16 )
4736 C PARAMETER ( MAXTAB = 20 )
4737 C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4738 C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4740 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4741 C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4743 C global event kinematics and particle IDs
4745 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4746 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4747 C hard cross sections and MC selection weights
4749 PARAMETER ( Max_pro_2 = 16 )
4750 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4752 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4753 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4754 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4755 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4756 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4757 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4758 C model switches and parameters
4760 INTEGER ISWMDL,IPAMDL
4761 DOUBLE PRECISION PARMDL
4762 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4763 C general process information
4764 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4765 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4767 DIMENSION PP(4),PT(4)
4770 DATA LSTART /.TRUE./
4775 * lepton-projectiles: initialize real photon instead
4776 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4780 IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4781 * switch Reggeon off
4784 IFPAP(1) = IDT_IPDGHA(IJP)
4788 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4790 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4791 PVIRT(1) = PMASS(1)**2
4793 IFPAP(2) = IDT_IPDGHA(IJT)
4797 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4799 PMASS(2) = AAM(IFPAB(2))
4805 * get max. possible momenta of incoming particles to be used for PHOJET ini.
4809 IF (UMO.GE.1.E5) THEN
4812 IF (NCOMPO.GT.0) THEN
4815 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4817 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4819 PPFTMP = MAX(PFERMP(1),PFERMN(1))
4820 PTFTMP = MAX(PFERMP(2),PFERMN(2))
4821 IF (PPFTMP.GT.PPF) PPF = PPFTMP
4822 IF (PTFTMP.GT.PTF) PTF = PTFTMP
4825 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4826 PPF = MAX(PFERMP(1),PFERMN(1))
4827 PTF = MAX(PFERMP(2),PFERMN(2))
4833 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4835 PP(4) = SQRT(AMP2+PP(3)**2)
4837 EPF = SQRT(PPF**2+PMASS(1)**2)
4838 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4840 ETF = SQRT(PTF**2+PMASS(2)**2)
4841 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4842 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4843 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4845 WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4847 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
4848 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4849 IF (NCOMPO.GT.0) THEN
4850 WRITE(LOUT,1002) SCPF,PTF,PT
4852 WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4855 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
4856 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4858 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
4859 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4860 WRITE(LOUT,1004) ECMINI
4861 1004 FORMAT(' E_cm = ',E10.3)
4862 IF (IJP.EQ.8) WRITE(LOUT,1005)
4864 & ' DT_PHOINI: warning! proton parameters used for neutron',
4868 * switch off new diffractive cross sections at low energies for nuclei
4869 * (temporary solution)
4870 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4871 WRITE(LOUT,'(1X,A)')
4872 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4873 CALL PHO_SETMDL(30,0,1)
4876 C IF (IJP.EQ.7) THEN
4877 C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4879 C PP(4) = SQRT(AMP2+PP(3)**2)
4882 C IF (IP.GT.1) PFERMX = 0.5D0
4883 C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4884 C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4887 C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4888 C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4889 C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4892 IF ((ISHAD(2).EQ.1).AND.
4893 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4894 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4896 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4901 * patch for cascade calculations:
4902 * define parton distribution functions for other hadrons, i.e. other
4903 * then defined already in phojet
4904 IF (IOGLB.EQ.100) THEN
4906 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4907 & ' assiged (ID,IPAR,ISET)',/)
4910 IF (IPARPD(I).NE.0) THEN
4912 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4913 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4914 IDPDG = IDT_IPDGHA(I)
4917 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4918 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4924 C CALL PHO_PHIST(-1,SIGMAX)
4925 IF (IREJ1.NE.0) THEN
4927 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
4934 *$ CREATE DT_EVENTD.FOR
4937 *===eventd=============================================================*
4939 SUBROUTINE DT_EVENTD(IREJ)
4941 ************************************************************************
4942 * Quasi-elastic neutrino nucleus scattering. *
4943 * This version dated 29.04.00 is written by S. Roesler. *
4944 ************************************************************************
4946 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4948 PARAMETER ( LINP = 10 ,
4951 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4952 PARAMETER (SQTINF=1.0D+15)
4957 PARAMETER (NMXHKK=200000)
4958 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4959 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4960 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4961 * extended event history
4962 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4963 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4965 * flags for input different options
4966 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4967 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4968 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4969 PARAMETER (MAXLND=4000)
4970 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4971 * properties of interacting particles
4972 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4973 * Lorentz-parameters of the current interaction
4974 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4975 & UMO,PPCM,EPROJ,PPROJ
4978 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4979 & EBINDP(2),EBINDN(2),EPOT(2,210),
4980 & ETACOU(2),ICOUL,LFERMI
4981 * steering flags for qel neutrino scattering modules
4982 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4983 COMMON /QNPOL/ POLARX(4),PMODUL
4986 DATA LFIRST /.TRUE./
4998 * interacting target nucleon
5000 IF (NEUDEC.LE.9) THEN
5001 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5009 RTYP = DT_RNDM(RTYP)
5010 ZFRAC = DBLE(ITZ)/DBLE(IT)
5011 IF (RTYP.LE.ZFRAC) THEN
5020 * select first nucleon in list with matching id and reset all other
5021 * nucleons which have been marked as "wounded" by ININUC
5024 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5029 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5033 & STOP ' EVENTD: interacting target nucleon not found! '
5035 * correct position of proj. lepton: assume position of target nucleon
5037 VHKK(I,1) = VHKK(I,IDX)
5038 WHKK(I,1) = WHKK(I,IDX)
5041 * load initial momenta for conservation check
5043 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5044 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5048 * quasi-elastic scattering
5049 IF (NEUDEC.LT.9) THEN
5050 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5051 & PHKK(4,IDX),PHKK(5,IDX))
5052 * CC event on p or n
5053 ELSEIF (NEUDEC.EQ.10) THEN
5054 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5055 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5056 * NC event on p or n
5057 ELSEIF (NEUDEC.EQ.11) THEN
5058 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5059 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5062 * get final state particles from Lund-common and write them into HKKEVT
5068 IF (K(I,1).EQ.1) THEN
5074 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5075 IDBJ = IDT_ICIHAD(ID)
5076 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5077 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5078 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5080 VHKK(1,NHKK) = VHKK(1,IDX)
5081 VHKK(2,NHKK) = VHKK(2,IDX)
5082 VHKK(3,NHKK) = VHKK(3,IDX)
5083 VHKK(4,NHKK) = VHKK(4,IDX)
5085 C WHKK(1,NHKK) = POLARX(1)
5086 C WHKK(2,NHKK) = POLARX(2)
5087 C WHKK(3,NHKK) = POLARX(3)
5088 C WHKK(4,NHKK) = POLARX(4)
5090 WHKK(1,NHKK) = WHKK(1,IDX)
5091 WHKK(2,NHKK) = WHKK(2,IDX)
5092 WHKK(3,NHKK) = WHKK(3,IDX)
5093 WHKK(4,NHKK) = WHKK(4,IDX)
5095 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5101 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5102 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5105 * transform momenta into cms (as required for inc etc.)
5107 IF (ISTHKK(I).EQ.1) THEN
5108 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5117 *$ CREATE DT_KKEVNT.FOR
5120 *===kkevnt=============================================================*
5122 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5124 ************************************************************************
5125 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5126 * without nuclear effects (one event). *
5127 * This subroutine is an update of the previous version (KKEVT) written *
5128 * by J. Ranft/ H.-J. Moehring. *
5129 * This version dated 20.04.95 is written by S. Roesler *
5130 ************************************************************************
5132 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5134 PARAMETER ( LINP = 10 ,
5137 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5139 PARAMETER ( MAXNCL = 260,
5141 & MAXSQU = 20*MAXVQU,
5142 & MAXINT = MAXVQU+MAXSQU)
5144 PARAMETER (NMXHKK=200000)
5145 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5146 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5147 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5148 * extended event history
5149 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5150 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5152 * flags for input different options
5153 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5154 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5155 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5157 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5158 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5159 & IREXCI(3),IRDIFF(2),IRINC
5161 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5162 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5164 * properties of interacting particles
5165 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5166 * Lorentz-parameters of the current interaction
5167 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5168 & UMO,PPCM,EPROJ,PPROJ
5169 * flags for diffractive interactions (DTUNUC 1.x)
5170 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5171 * interface HADRIN-DPM
5172 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5173 * nucleon-nucleon event-generator
5176 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5177 * coordinates of nucleons
5178 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5179 * interface between Glauber formalism and DPM
5180 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5181 & INTER1(MAXINT),INTER2(MAXINT)
5182 * Glauber formalism: collision properties
5183 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5184 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5186 * central particle production, impact parameter biasing
5187 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5189 * statistics: Glauber-formalism
5190 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5193 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5204 IF (MOD(NC,10).EQ.0) THEN
5205 WRITE(LOUT,1000) NEVHKK
5206 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5210 * initialize DTEVT1/DTEVT2
5213 * We need the following only in order to sample nucleon coordinates.
5214 * However we don't have parameters (cross sections, slope etc.)
5215 * for neutrinos available. Therefore switch projectile to proton
5217 IF (MCGENE.EQ.4) THEN
5224 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5225 * make sure that Glauber-formalism is called each time the interaction
5226 * configuration changed
5227 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5228 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5229 * sample number of nucleon-nucleon coll. according to Glauber-form.
5230 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5241 * WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5245 * WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5249 * force diffractive particle production in h-K interactions
5250 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5251 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5256 * check number of involved proj. nucl. (NP) if central prod.is requested
5257 IF (ICENTR.GT.0) THEN
5258 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5259 IF (IBACK.GT.0) GOTO 10
5262 * get initial nucleon-configuration in projectile and target
5263 * rest-system (including Fermi-momenta if requested)
5264 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5266 IF (EPROJ.LE.EHADTH) MODE = 3
5267 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5269 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5271 * activate HADRIN at low energies (implemented for h-N scattering only)
5272 IF (EPROJ.LE.EHADHI) THEN
5273 IF (EHADTH.LT.ZERO) THEN
5274 * smooth transition btwn. DPM and HADRIN
5275 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5277 IF (RR.GT.FRAC) THEN
5279 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5280 IF (IREJ1.GT.0) GOTO 1
5283 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5287 * fixed threshold for onset of production via HADRIN
5288 IF (EPROJ.LE.EHADTH) THEN
5290 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5291 IF (IREJ1.GT.0) GOTO 1
5294 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5299 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5300 & I3,') with target (m=',I3,')',/,11X,
5301 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5302 & 'GeV) cannot be handled')
5304 * sampling of momentum-x fractions & flavors of chain ends
5307 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5310 * collect momenta of chain ends and put them into DTEVT1
5311 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5312 IF (IREJ1.NE.0) GOTO 1
5316 * handle chains including fragmentation (two-chain approximation)
5317 IF (MCGENE.EQ.1) THEN
5318 * two-chain approximation
5319 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5320 IF (IREJ1.NE.0) THEN
5321 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5324 ELSEIF (MCGENE.EQ.2) THEN
5325 * multiple-Po exchange including minijets
5326 CALL DT_EVENTB(NCSY,IREJ1)
5327 IF (IREJ1.NE.0) THEN
5328 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5331 ELSEIF (MCGENE.EQ.3) THEN
5332 STOP ' This version does not contain LEPTO !'
5333 ELSEIF (MCGENE.EQ.4) THEN
5334 * quasi-elastic neutrino scattering
5335 CALL DT_EVENTD(IREJ1)
5336 IF (IREJ1.NE.0) THEN
5337 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5341 WRITE(LOUT,1002) MCGENE
5342 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5343 & ' not available - program stopped')
5354 *$ CREATE DT_CHKCEN.FOR
5357 *===chkcen=============================================================*
5359 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5361 ************************************************************************
5362 * Check of number of involved projectile nucleons if central production*
5364 * Adopted from a part of the old KKEVT routine which was written by *
5365 * J. Ranft/H.-J.Moehring. *
5366 * This version dated 13.01.95 is written by S. Roesler *
5367 ************************************************************************
5369 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5371 PARAMETER ( LINP = 10 ,
5376 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5377 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5379 * central particle production, impact parameter biasing
5380 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5385 IF (ICENTR.EQ.2) THEN
5388 IF (NP.LT.IP-1) IBACK = 1
5389 ELSEIF (IP.LE.16) THEN
5390 IF (NP.LT.IP-2) IBACK = 1
5391 ELSEIF (IP.LE.32) THEN
5392 IF (NP.LT.IP-3) IBACK = 1
5393 ELSEIF (IP.GE.33) THEN
5394 IF (NP.LT.IP-5) IBACK = 1
5396 ELSEIF (IP.EQ.IT) THEN
5398 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5400 IF (NP.LT.IP-IP/8) IBACK = 1
5402 ELSEIF (ABS(IP-IT).LT.3) THEN
5403 IF (NP.LT.IP-IP/8) IBACK = 1
5406 * new version (DPMJET, 5.6.99)
5409 IF (NP.LT.IP-1) IBACK = 1
5410 ELSEIF (IP.LE.16) THEN
5411 IF (NP.LT.IP-2) IBACK = 1
5412 ELSEIF (IP.LT.32) THEN
5413 IF (NP.LT.IP-3) IBACK = 1
5414 ELSEIF (IP.GE.32) THEN
5417 IF (NP.LT.IP-1) IBACK = 1
5420 IF (NP.LT.IP) IBACK = 1
5423 ELSEIF (IP.EQ.IT) THEN
5426 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5429 IF (NP.LT.IP-IP/4) IBACK = 1
5431 ELSEIF (ABS(IP-IT).LT.3) THEN
5432 IF (NP.LT.IP-IP/8) IBACK = 1
5441 *$ CREATE DT_ININUC.FOR
5444 *===ininuc=============================================================*
5446 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5448 ************************************************************************
5449 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5450 * including Fermi-momenta (if reqested). *
5451 * ID BAMJET-code for hadrons (instead of nuclei) *
5452 * NMASS mass number of nucleus (number of nucleons) *
5453 * NCH charge of nucleus *
5454 * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5455 * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5456 * IMODE = 1 projectile nucleus *
5457 * = 2 target nucleus *
5458 * = 3 target nucleus (E_lab<E_thr for HADRIN) *
5459 * Adopted from a part of the old KKEVT routine which was written by *
5460 * J. Ranft/H.-J.Moehring. *
5461 * This version dated 13.01.95 is written by S. Roesler *
5462 ************************************************************************
5464 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5466 PARAMETER ( LINP = 10 ,
5469 PARAMETER (FM2MM=1.0D-12)
5471 PARAMETER ( MAXNCL = 260,
5473 & MAXSQU = 20*MAXVQU,
5474 & MAXINT = MAXVQU+MAXSQU)
5476 PARAMETER (NMXHKK=200000)
5477 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5478 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5479 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5480 * extended event history
5481 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5482 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5484 * flags for input different options
5485 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5486 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5487 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5488 * auxiliary common for chain system storage (DTUNUC 1.x)
5489 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5492 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5493 & EBINDP(2),EBINDN(2),EPOT(2,210),
5494 & ETACOU(2),ICOUL,LFERMI
5495 * properties of photon/lepton projectiles
5496 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5497 * particle properties (BAMJET index convention)
5499 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5500 & IICH(210),IIBAR(210),K1(210),K2(210)
5501 * Glauber formalism: collision properties
5502 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5503 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5504 * flavors of partons (DTUNUC 1.x)
5505 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5506 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5507 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5508 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5509 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5510 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5511 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5512 * interface HADRIN-DPM
5513 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5515 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5517 * number of neutrons
5526 IF (IMODE.GT.2) MODE = 2
5527 **sr 29.5. new NPOINT(1)-definition
5528 C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5533 * get initial configuration
5536 IF (JS(I).GT.0) THEN
5537 ISTHKK(NHKK) = 10+MODE
5538 IF (IMODE.EQ.3) THEN
5539 * additional treatment if HADRIN-generator is requested
5541 IF (NHADRI.EQ.1) IDXTA = NHKK
5542 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5545 ISTHKK(NHKK) = 12+MODE
5547 IF (NMASS.GE.2) THEN
5548 * treatment for nuclei
5549 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5551 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5554 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5557 ELSEIF (NN.LT.NNEU) THEN
5560 ELSEIF (NP.LT.NCH) THEN
5564 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5575 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5578 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5580 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5582 PFTOT(K) = PFTOT(K)+PF(K)
5583 PHKK(K,NHKK) = PF(K)
5585 PHKK(5,NHKK) = AAM(IDX)
5587 * treatment for hadrons
5588 IDHKK(NHKK) = IDT_IPDGHA(ID)
5590 PHKK(4,NHKK) = AAM(ID)
5591 PHKK(5,NHKK) = AAM(ID)
5593 C IF (IDHKK(NHKK).EQ.22) THEN
5594 C PHKK(4,NHKK) = AAM(33)
5595 C PHKK(5,NHKK) = AAM(33)
5600 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5607 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5608 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5610 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5611 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5612 VHKK(4,NHKK) = 0.0D0
5613 WHKK(4,NHKK) = 0.0D0
5616 * balance Fermi-momenta
5617 IF (NMASS.GE.2) THEN
5621 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5623 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5624 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5631 *$ CREATE DT_FER4M.FOR
5634 *===fer4m==============================================================*
5636 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5638 ************************************************************************
5639 * Sampling of nucleon Fermi-momenta from distributions at T=0. *
5640 * processed by S. Roesler, 17.10.95 *
5641 ************************************************************************
5643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5645 PARAMETER ( LINP = 10 ,
5651 * particle properties (BAMJET index convention)
5653 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5654 & IICH(210),IIBAR(210),K1(210),K2(210)
5657 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5658 & EBINDP(2),EBINDN(2),EPOT(2,210),
5659 & ETACOU(2),ICOUL,LFERMI
5661 DATA LSTART /.TRUE./
5667 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
5671 CALL DT_DFERMI(PABS)
5673 C IF (PABS.GE.PBIND) THEN
5675 C IF (MOD(ILOOP,500).EQ.0) THEN
5676 C WRITE(LOUT,1001) PABS,PBIND,ILOOP
5677 C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
5678 C & ' energy ',2E12.3,I6)
5682 CALL DT_DPOLI(POLC,POLS)
5683 CALL DT_DSFECF(SFE,CFE)
5687 ET = SQRT(PABS*PABS+AAM(KT)**2)
5701 *$ CREATE DT_NUC2CM.FOR
5704 *===nuc2cm=============================================================*
5706 SUBROUTINE DT_NUC2CM
5708 ************************************************************************
5709 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
5710 * nucl. cms. (This subroutine replaces NUCMOM.) *
5711 * This version dated 15.01.95 is written by S. Roesler *
5712 ************************************************************************
5714 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5716 PARAMETER ( LINP = 10 ,
5719 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5722 PARAMETER (NMXHKK=200000)
5723 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5724 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5725 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5726 * extended event history
5727 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5728 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5731 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5732 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5734 * properties of photon/lepton projectiles
5735 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5736 * particle properties (BAMJET index convention)
5738 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5739 & IICH(210),IIBAR(210),K1(210),K2(210)
5740 * Glauber formalism: collision properties
5741 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5742 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5744 * statistics: Glauber-formalism
5745 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5757 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5758 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5759 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5761 C IF (IDHKK(I).EQ.22) THEN
5769 C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5770 C & PX,PY,PZ,PE,IDB,MODE)
5771 IF (PHKK(5,I).GT.ZERO) THEN
5772 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5773 & PX,PY,PZ,PE,IDBAM(I),MODE)
5783 C IF (ID.EQ.22) ID = 113
5784 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5785 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5786 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5790 NWTACC = MAX(NWAACC,NWBACC)
5794 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5802 *$ CREATE DT_SPLPTN.FOR
5805 *===splptn=============================================================*
5807 SUBROUTINE DT_SPLPTN(NN)
5809 ************************************************************************
5810 * SamPLing of ParToN momenta and flavors. *
5811 * This version dated 15.01.95 is written by S. Roesler *
5812 ************************************************************************
5814 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5816 PARAMETER ( LINP = 10 ,
5820 * Lorentz-parameters of the current interaction
5821 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5822 & UMO,PPCM,EPROJ,PPROJ
5824 * sample flavors of sea-quarks
5825 CALL DT_SPLFLA(NN,1)
5827 * sample x-values of partons at chain ends
5829 CALL DT_XKSAMP(NN,ECM)
5832 CALL DT_SPLFLA(NN,2)
5837 *$ CREATE DT_SPLFLA.FOR
5840 *===splfla=============================================================*
5842 SUBROUTINE DT_SPLFLA(NN,MODE)
5844 ************************************************************************
5845 * SamPLing of FLAvors of partons at chain ends. *
5846 * This subroutine replaces FLKSAA/FLKSAM. *
5847 * NN number of nucleon-nucleon interactions *
5848 * MODE = 1 sea-flavors *
5849 * = 2 valence-flavors *
5850 * Based on the original version written by J. Ranft/H.-J. Moehring. *
5851 * This version dated 16.01.95 is written by S. Roesler *
5852 ************************************************************************
5854 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5856 PARAMETER ( LINP = 10 ,
5860 PARAMETER ( MAXNCL = 260,
5862 & MAXSQU = 20*MAXVQU,
5863 & MAXINT = MAXVQU+MAXSQU)
5864 * flavors of partons (DTUNUC 1.x)
5865 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5866 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5867 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5868 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5869 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5870 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5871 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5872 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5873 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5874 & IXPV,IXPS,IXTV,IXTS,
5875 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5876 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5877 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5878 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5879 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5880 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5881 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5882 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5883 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5884 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5885 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5886 * particle properties (BAMJET index convention)
5888 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5889 & IICH(210),IIBAR(210),K1(210),K2(210)
5890 * various options for treatment of partons (DTUNUC 1.x)
5891 * (chain recombination, Cronin,..)
5892 LOGICAL LCO2CR,LINTPT
5893 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5899 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5903 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5906 ELSEIF (MODE.EQ.2) THEN
5909 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5912 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5919 *$ CREATE DT_GETPTN.FOR
5922 *===getptn=============================================================*
5924 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5926 ************************************************************************
5927 * This subroutine collects partons at chain ends from temporary *
5928 * commons and puts them into DTEVT1. *
5929 * This version dated 15.01.95 is written by S. Roesler *
5930 ************************************************************************
5932 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5934 PARAMETER ( LINP = 10 ,
5937 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5941 PARAMETER ( MAXNCL = 260,
5943 & MAXSQU = 20*MAXVQU,
5944 & MAXINT = MAXVQU+MAXSQU)
5946 PARAMETER (NMXHKK=200000)
5947 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5948 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5949 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5950 * extended event history
5951 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5952 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5954 * flags for input different options
5955 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5956 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5957 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5958 * auxiliary common for chain system storage (DTUNUC 1.x)
5959 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5961 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5962 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5964 * flags for diffractive interactions (DTUNUC 1.x)
5965 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5966 * x-values of partons (DTUNUC 1.x)
5967 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5968 & XTVQ(MAXVQU),XTVD(MAXVQU),
5969 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
5970 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
5971 * flavors of partons (DTUNUC 1.x)
5972 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5973 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5974 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5975 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5976 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5977 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5978 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5979 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5980 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5981 & IXPV,IXPS,IXTV,IXTS,
5982 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5983 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5984 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5985 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5986 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5987 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5988 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5989 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5990 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5991 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5992 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5994 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
5996 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6004 IF (ISKPCH(1,I).EQ.99) GOTO 10
6005 ICCHAI(1,1) = ICCHAI(1,1)+2
6008 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6009 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6011 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6012 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6013 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6014 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6016 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6017 & +(PP1(3)+PT1(3))**2)
6019 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6020 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6021 & +(PP2(3)+PT2(3))**2)
6023 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6024 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6027 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6028 C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6029 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6032 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6034 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6035 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6036 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6037 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6038 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6040 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6042 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6044 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6051 IF (ISKPCH(2,I).EQ.99) GOTO 20
6052 ICCHAI(1,2) = ICCHAI(1,2)+2
6055 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6056 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6058 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6059 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6060 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6061 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6063 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6064 & +(PP1(3)+PT1(3))**2)
6066 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6067 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6068 & +(PP2(3)+PT2(3))**2)
6070 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6071 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6074 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6075 C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6076 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6079 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6081 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6082 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6083 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6084 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6085 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6087 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6089 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6091 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6098 IF (ISKPCH(3,I).EQ.99) GOTO 30
6099 ICCHAI(1,3) = ICCHAI(1,3)+2
6102 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6103 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6105 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6106 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6107 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6108 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6110 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6111 & +(PP1(3)+PT1(3))**2)
6113 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6114 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6115 & +(PP2(3)+PT2(3))**2)
6117 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6118 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6121 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6122 C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6123 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6126 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6128 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6129 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6130 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6131 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6132 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6134 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6136 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6138 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6143 * disea-valence chains
6145 IF (ISKPCH(5,I).EQ.99) GOTO 50
6146 ICCHAI(1,5) = ICCHAI(1,5)+2
6149 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6150 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6152 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6153 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6154 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6155 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6157 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6158 & +(PP1(3)+PT1(3))**2)
6160 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6161 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6162 & +(PP2(3)+PT2(3))**2)
6164 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6165 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6168 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6169 C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6170 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6173 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6175 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6176 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6177 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6178 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6179 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6181 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6183 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6185 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6190 * valence-sea chains
6192 IF (ISKPCH(6,I).EQ.99) GOTO 60
6193 ICCHAI(1,6) = ICCHAI(1,6)+2
6196 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6197 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6199 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6200 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6201 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6202 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6204 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6205 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6206 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6207 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6208 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6210 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6212 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6214 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6216 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6218 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6219 & +(PP1(3)+PT1(3))**2)
6221 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6222 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6223 & +(PP2(3)+PT2(3))**2)
6225 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6227 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6229 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6231 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6233 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6235 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6236 & +(PP1(3)+PT2(3))**2)
6238 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6239 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6240 & +(PP2(3)+PT1(3))**2)
6242 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6244 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6247 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6248 C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6249 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6252 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6257 * sea-valence chains
6259 IF (ISKPCH(4,I).EQ.99) GOTO 40
6260 ICCHAI(1,4) = ICCHAI(1,4)+2
6263 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6264 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6266 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6267 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6268 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6269 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6271 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6272 & +(PP1(3)+PT1(3))**2)
6274 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6275 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6276 & +(PP2(3)+PT2(3))**2)
6278 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6279 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6282 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6283 C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6284 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6287 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6289 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6290 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6291 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6292 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6293 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6295 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6297 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6299 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6304 * valence-disea chains
6306 IF (ISKPCH(7,I).EQ.99) GOTO 70
6307 ICCHAI(1,7) = ICCHAI(1,7)+2
6310 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6311 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6313 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6314 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6315 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6316 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6318 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6319 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6320 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6321 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6322 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6324 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6326 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6328 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6330 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6332 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6333 & +(PP1(3)+PT1(3))**2)
6335 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6336 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6337 & +(PP2(3)+PT2(3))**2)
6339 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6341 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6343 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6345 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6347 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6349 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6350 & +(PP1(3)+PT2(3))**2)
6352 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6353 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6354 & +(PP2(3)+PT1(3))**2)
6356 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6358 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6361 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6362 C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6363 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6366 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6371 * valence-valence chains
6373 IF (ISKPCH(8,I).EQ.99) GOTO 80
6374 ICCHAI(1,8) = ICCHAI(1,8)+2
6377 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6378 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6380 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6381 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6382 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6383 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6385 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6386 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6387 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6388 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6390 * check for diffractive event
6392 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6393 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6395 PP(K) = PP1(K)+PP2(K)
6396 PT(K) = PT1(K)+PT2(K)
6399 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6400 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6401 C IF (IREJ1.NE.0) GOTO 9999
6402 IF (IREJ1.NE.0) THEN
6410 IF (IDIFF.EQ.0) THEN
6411 * valence-valence chain system
6412 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6415 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6416 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6417 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6418 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6419 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6420 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6421 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6422 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6423 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6424 & +(PP1(3)+PT1(3))**2)
6426 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6427 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6428 & +(PP2(3)+PT2(3))**2)
6430 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6433 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6434 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6435 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6436 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6437 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6438 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6439 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6440 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6441 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6442 & +(PP1(3)+PT2(3))**2)
6444 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6445 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6446 & +(PP2(3)+PT1(3))**2)
6448 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6450 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6453 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6454 C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6455 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6458 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6463 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6465 * energy-momentum & flavor conservation check
6466 IF (ABS(IDIFF).NE.1) THEN
6467 IF (IDIFF.NE.0) THEN
6468 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6471 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6487 *$ CREATE DT_CHKCSY.FOR
6490 *===chkcsy=============================================================*
6492 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6494 ************************************************************************
6495 * CHeCk Chain SYstem for consistency of partons at chain ends. *
6496 * ID1,ID2 PDG-numbers of partons at chain ends *
6497 * LCHK = .true. consistent chain *
6498 * = .false. inconsistent chain *
6499 * This version dated 18.01.95 is written by S. Roesler *
6500 ************************************************************************
6502 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6504 PARAMETER ( LINP = 10 ,
6513 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6514 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6515 * q-qq, aq-aqaq chain
6516 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6517 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6518 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6520 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6521 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6527 *$ CREATE DT_EVENTA.FOR
6530 *===eventa=============================================================*
6532 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6534 ************************************************************************
6535 * Treatment of nucleon-nucleon interactions in a two-chain *
6537 * (input) ID BAMJET-index of projectile hadron (in case of *
6539 * IP/IT mass number of projectile/target nucleus *
6540 * NCSY number of two chain systems *
6541 * IREJ rejection flag *
6542 * This version dated 15.01.95 is written by S. Roesler *
6543 ************************************************************************
6545 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6547 PARAMETER ( LINP = 10 ,
6550 PARAMETER (TINY10=1.0D-10)
6553 PARAMETER (NMXHKK=200000)
6554 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6555 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6556 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6557 * extended event history
6558 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6559 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6562 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6563 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6564 & IREXCI(3),IRDIFF(2),IRINC
6565 * flags for diffractive interactions (DTUNUC 1.x)
6566 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6567 * particle properties (BAMJET index convention)
6569 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6570 & IICH(210),IIBAR(210),K1(210),K2(210)
6571 * flags for input different options
6572 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6573 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6574 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6575 * various options for treatment of partons (DTUNUC 1.x)
6576 * (chain recombination, Cronin,..)
6577 LOGICAL LCO2CR,LINTPT
6578 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6581 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6586 * skip following treatment for low-mass diffraction
6587 IF (ABS(IFLAGD).EQ.1) THEN
6588 NPOINT(3) = NPOINT(2)
6592 * multiple scattering of chain ends
6593 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6594 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6597 * get a two-chain system from DTEVT1
6605 PT1(K) = PHKK(K,NC+1)
6606 PP2(K) = PHKK(K,NC+2)
6607 PT2(K) = PHKK(K,NC+3)
6613 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6614 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6615 IF (IREJ1.GT.0) THEN
6617 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6623 * meson/antibaryon projectile:
6624 * sample single-chain valence-valence systems (Reggeon contrib.)
6625 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6626 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6629 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6630 * check DTEVT1 for remaining resonance mass corrections
6631 CALL DT_EVTRES(IREJ1)
6632 IF (IREJ1.GT.0) THEN
6633 IRRES(1) = IRRES(1)+1
6634 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6639 * assign p_t to two-"chain" systems consisting of two resonances only
6640 * since only entries for chains will be affected, this is obsolete
6641 * in case of JETSET-fragmetation
6644 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6645 IF (LCO2CR) CALL DT_COM2CR
6649 * fragmentation of the complete event
6650 **uncomment for internal phojet-fragmentation
6651 C CALL DT_EVTFRA(IREJ1)
6652 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6653 IF (IREJ1.GT.0) THEN
6655 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6659 * decay of possible resonances (should be obsolete)
6670 *$ CREATE DT_GETCSY.FOR
6673 *===getcsy=============================================================*
6675 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6676 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6678 ************************************************************************
6679 * This version dated 15.01.95 is written by S. Roesler *
6680 ************************************************************************
6682 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6684 PARAMETER ( LINP = 10 ,
6687 PARAMETER (TINY10=1.0D-10)
6690 PARAMETER (NMXHKK=200000)
6691 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6692 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6693 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6694 * extended event history
6695 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6696 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6699 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6700 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6701 & IREXCI(3),IRDIFF(2),IRINC
6702 * flags for input different options
6703 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6704 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6705 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6706 * flags for diffractive interactions (DTUNUC 1.x)
6707 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6709 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6710 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6714 * get quark content of partons
6721 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6722 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6723 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6724 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6725 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6726 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6727 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6728 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6730 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6732 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6733 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6735 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6736 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6738 * store initial configuration for energy-momentum cons. check
6739 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6741 * sample intrinsic p_t at chain-ends
6742 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6743 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6744 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6745 IF (IREJ1.NE.0) THEN
6746 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6751 C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6752 C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6753 C* check second chain for resonance
6754 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6755 C & AMCH2,AMCH2N,IDCH2,IREJ1)
6756 C IF (IREJ1.NE.0) GOTO 9999
6757 C IF (IDR2.NE.0) THEN
6758 C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6759 C & AMCH2,AMCH2N,AMCH1,IREJ1)
6760 C IF (IREJ1.NE.0) GOTO 9999
6762 C* check first chain for resonance
6763 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6764 C & AMCH1,AMCH1N,IDCH1,IREJ1)
6765 C IF (IREJ1.NE.0) GOTO 9999
6766 C IF (IDR1.NE.0) IDR1 = 100*IDR1
6768 C* check first chain for resonance
6769 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6770 C & AMCH1,AMCH1N,IDCH1,IREJ1)
6771 C IF (IREJ1.NE.0) GOTO 9999
6772 C IF (IDR1.NE.0) THEN
6773 C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6774 C & AMCH1,AMCH1N,AMCH2,IREJ1)
6775 C IF (IREJ1.NE.0) GOTO 9999
6777 C* check second chain for resonance
6778 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6779 C & AMCH2,AMCH2N,IDCH2,IREJ1)
6780 C IF (IREJ1.NE.0) GOTO 9999
6781 C IF (IDR2.NE.0) IDR2 = 100*IDR2
6785 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6786 * check chains for resonances
6787 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6788 & AMCH1,AMCH1N,IDCH1,IREJ1)
6789 IF (IREJ1.NE.0) GOTO 9999
6790 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6791 & AMCH2,AMCH2N,IDCH2,IREJ1)
6792 IF (IREJ1.NE.0) GOTO 9999
6793 * change kinematics corresponding to resonance-masses
6794 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6795 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6796 & AMCH1,AMCH1N,AMCH2,IREJ1)
6797 IF (IREJ1.GT.0) GOTO 9999
6798 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6799 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6800 & AMCH2,AMCH2N,IDCH2,IREJ1)
6801 IF (IREJ1.NE.0) GOTO 9999
6802 IF (IDR2.NE.0) IDR2 = 100*IDR2
6803 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6804 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6805 & AMCH2,AMCH2N,AMCH1,IREJ1)
6806 IF (IREJ1.GT.0) GOTO 9999
6807 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6808 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6809 & AMCH1,AMCH1N,IDCH1,IREJ1)
6810 IF (IREJ1.NE.0) GOTO 9999
6811 IF (IDR1.NE.0) IDR1 = 100*IDR1
6812 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6813 AMDIF1 = ABS(AMCH1-AMCH1N)
6814 AMDIF2 = ABS(AMCH2-AMCH2N)
6815 IF (AMDIF2.LT.AMDIF1) THEN
6816 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6817 & AMCH2,AMCH2N,AMCH1,IREJ1)
6818 IF (IREJ1.GT.0) GOTO 9999
6819 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6820 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6821 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6822 IF (IREJ1.NE.0) GOTO 9999
6823 IF (IDR1.NE.0) IDR1 = 100*IDR1
6825 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6826 & AMCH1,AMCH1N,AMCH2,IREJ1)
6827 IF (IREJ1.GT.0) GOTO 9999
6828 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6829 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6830 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6831 IF (IREJ1.NE.0) GOTO 9999
6832 IF (IDR2.NE.0) IDR2 = 100*IDR2
6837 * store final configuration for energy-momentum cons. check
6839 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6840 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6841 IF (IREJ1.NE.0) GOTO 9999
6844 * put partons and chains into DTEVT1
6846 PCH1(I) = PP1(I)+PT1(I)
6847 PCH2(I) = PP2(I)+PT2(I)
6849 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6850 & PP1(3),PP1(4),0,0,0)
6851 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6852 & PT1(3),PT1(4),0,0,0)
6853 KCH = 100+IDCH(MOP1)*10+1
6854 CALL DT_EVTPUT(KCH,88888,-2,-1,
6855 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6856 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6857 & PP2(3),PP2(4),0,0,0)
6858 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6859 & PT2(3),PT2(4),0,0,0)
6861 CALL DT_EVTPUT(KCH,88888,-2,-1,
6862 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6867 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6868 * "cancel" sea-sea chains
6869 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6870 IF (IREJ1.NE.0) GOTO 9998
6871 **sr 16.5. flag for EVENTB
6880 *$ CREATE DT_CHKINE.FOR
6883 *===chkine=============================================================*
6885 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6886 & AMCH1,AMCH1N,AMCH2,IREJ)
6888 ************************************************************************
6889 * This subroutine replaces CORMOM. *
6890 * This version dated 05.01.95 is written by S. Roesler *
6891 ************************************************************************
6893 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6895 PARAMETER ( LINP = 10 ,
6898 PARAMETER (TINY10=1.0D-10)
6900 * flags for input different options
6901 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6902 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6903 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6905 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6906 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6907 & IREXCI(3),IRDIFF(2),IRINC
6909 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6910 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6915 SCALE = AMCH1N/MAX(AMCH1,TINY10)
6921 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6922 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6923 PP1(I) = SCALE*PP1(I)
6924 PT1(I) = SCALE*PT1(I)
6926 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6927 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6930 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6931 & (PP2(3)+PT2(3))**2 )
6932 AMCH22 = (ECH-PCH)*(ECH+PCH)
6933 IF (AMCH22.LT.0.0D0) THEN
6935 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6940 AMCH2 = SQRT(AMCH22)
6942 * put partons again on mass shell
6946 IF (JMSHL.EQ.1) THEN
6950 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6951 IF (IREJ1.NE.0) THEN
6952 IF (JMSHL.EQ.0) GOTO 9998
6964 IF (JMSHL.EQ.1) THEN
6968 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6969 IF (IREJ1.NE.0) THEN
6970 IF (JMSHL.EQ.0) GOTO 9998
6986 9997 IRCHKI(1) = IRCHKI(1)+1
6992 9998 IRCHKI(2) = IRCHKI(2)+1
6995 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7000 *$ CREATE DT_CH2RES.FOR
7003 *===ch2res=============================================================*
7005 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7006 & AM,AMN,IMODE,IREJ)
7008 ************************************************************************
7009 * Check chains for resonance production. *
7010 * This subroutine replaces COMCMA/COBCMA/COMCM2 *
7012 * IF1,2,3,4 input flavors (q,aq in any order) *
7014 * MODE = 1 check q-aq chain for meson-resonance *
7015 * = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7016 * = 3 check qq-aqaq chain for lower mass cut *
7018 * IDR = 0 no resonances found *
7019 * = -1 pseudoscalar meson/octet baryon *
7020 * = 1 vector-meson/decuplet baryon *
7021 * IDXR BAMJET-index of corresponding resonance *
7022 * AMN mass of corresponding resonance *
7024 * IREJ rejection flag *
7025 * This version dated 06.01.95 is written by S. Roesler *
7026 ************************************************************************
7028 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7030 PARAMETER ( LINP = 10 ,
7034 * particle properties (BAMJET index convention)
7036 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7037 & IICH(210),IIBAR(210),K1(210),K2(210)
7038 * quark-content to particle index conversion (DTUNUC 1.x)
7039 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7040 & IA08(6,21),IA10(6,21)
7042 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7043 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7044 & IREXCI(3),IRDIFF(2),IRINC
7045 * flags for input different options
7046 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7047 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7048 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7050 DIMENSION IF(4),JF(4)
7053 C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7054 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7056 C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7060 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7061 WRITE(LOUT,1000) MODE
7062 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7063 & 1X,' program stopped')
7072 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7073 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7081 IF (IF(I).NE.0) THEN
7086 IF (NF.LE.MODE) THEN
7087 WRITE(LOUT,1001) MODE,IF
7088 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7089 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7095 * check for meson resonance
7099 IF (JF(2).GT.0) THEN
7103 IFPS = IMPS(IFAQ,IFQ)
7104 IFV = IMVE(IFAQ,IFQ)
7108 IF (AMX.LT.AMV) THEN
7109 IF (AMX.LT.AMPS) THEN
7110 IF (IMODE.GT.0) THEN
7111 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7113 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7117 * replace chain by pseudoscalar meson
7121 ELSEIF (AMX.LT.AMHI) THEN
7122 * replace chain by vector-meson
7129 * check for baryon resonance
7131 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7135 IF (AMX.LT.AM10) THEN
7136 IF (AMX.LT.AM8) THEN
7137 IF (IMODE.GT.0) THEN
7138 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7140 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7144 * replace chain by oktet baryon
7148 ELSEIF (AMX.LT.AMHI) THEN
7155 * check qq-aqaq for lower mass cut
7157 * empirical definition of AMHI to allow for (b-antib)-pair prod.
7159 IF (AMX.LT.AMHI) GOTO 9999
7163 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7164 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7166 IRRES(2) = IRRES(2)+1
7170 *$ CREATE DT_RJSEAC.FOR
7173 *===rjseac=============================================================*
7175 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7177 ************************************************************************
7178 * ReJection of SEA-sea Chains. *
7179 * MOP1/2 entries of projectile sea-partons in DTEVT1 *
7180 * MOT1/2 entries of projectile sea-partons in DTEVT1 *
7181 * This version dated 16.01.95 is written by S. Roesler *
7182 ************************************************************************
7184 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7186 PARAMETER ( LINP = 10 ,
7189 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7192 PARAMETER (NMXHKK=200000)
7193 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7194 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7195 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7196 * extended event history
7197 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7198 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7201 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7202 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7205 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7209 * projectile sea q-aq-pair
7210 * indices of sea-pair
7213 * index of mother-nucleon
7214 IDXNUC(1) = JMOHKK(1,MOP1)
7215 * status of valence quarks to be corrected
7218 * target sea q-aq-pair
7219 * indices of sea-pair
7222 * index of mother-nucleon
7223 IDXNUC(2) = JMOHKK(1,MOT1)
7224 * status of valence quarks to be corrected
7229 DO 2 I=NPOINT(2),NHKK
7230 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7231 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7232 * valence parton found
7233 * inrease 4-momentum by sea 4-momentum
7235 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7236 & PHKK(K,IDXSEA(N,2))
7238 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7239 & PHKK(2,I)**2-PHKK(3,I)**2))
7242 ISTHKK(IDXSEA(N,J)) = 100
7243 IDHKK(IDXSEA(N,J)) = 0
7244 JMOHKK(1,IDXSEA(N,J)) = 0
7245 JMOHKK(2,IDXSEA(N,J)) = 0
7246 JDAHKK(1,IDXSEA(N,J)) = 0
7247 JDAHKK(2,IDXSEA(N,J)) = 0
7249 PHKK(K,IDXSEA(N,J)) = ZERO
7250 VHKK(K,IDXSEA(N,J)) = ZERO
7251 WHKK(K,IDXSEA(N,J)) = ZERO
7253 PHKK(5,IDXSEA(N,J)) = ZERO
7258 IF (IDONE.NE.1) THEN
7259 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7260 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7261 & '-record!',/,1X,' sea-quark pairs ',
7262 & 2I5,4X,2I5,' could not be canceled!')
7274 *$ CREATE DT_VV2SCH.FOR
7277 *===vv2sch=============================================================*
7279 SUBROUTINE DT_VV2SCH
7281 ************************************************************************
7282 * Change Valence-Valence chain systems to Single CHain systems for *
7283 * hadron-nucleus collisions with meson or antibaryon projectile. *
7284 * (Reggeon contribution) *
7285 * The single chain system is approximately treated as one chain and a *
7287 * This version dated 18.01.95 is written by S. Roesler *
7288 ************************************************************************
7290 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7292 PARAMETER ( LINP = 10 ,
7295 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7300 PARAMETER (NMXHKK=200000)
7301 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7302 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7303 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7304 * extended event history
7305 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7306 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7308 * flags for input different options
7309 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7310 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7311 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7313 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7314 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7317 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7320 DATA LSTART /.TRUE./
7325 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7326 & 'valence chains treated')
7332 * get index of first chain
7333 DO 1 I=NPOINT(3),NHKK
7334 IF (IDHKK(I).EQ.88888) THEN
7341 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7342 & .AND.(NC.LT.NSTOP)) THEN
7343 * get valence-valence chains
7344 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7345 * get "mother"-hadron indices
7346 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7347 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7348 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7349 KTARG = IDT_ICIHAD(IDHKK(MO2))
7350 * Lab momentum of projectile hadron
7351 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7352 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7355 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7356 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7358 * single chain requested
7359 * get flavors of chain-end partons
7360 MO(1) = JMOHKK(1,NC)
7361 MO(2) = JMOHKK(2,NC)
7362 MO(3) = JMOHKK(1,NC+3)
7363 MO(4) = JMOHKK(2,NC+3)
7365 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7367 IF (ABS(IDHKK(MO(I))).GE.1000)
7368 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7370 * which one is the q-aq chain?
7371 * N1,N1+1 - DTEVT1-entries for q-aq system
7372 * N2,N2+1 - DTEVT1-entries for the other chain
7373 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7378 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7388 PT1(K) = PHKK(K,N1+1)
7390 PT2(K) = PHKK(K,N2+1)
7392 AMCH1 = PHKK(5,N1+2)
7393 AMCH2 = PHKK(5,N2+2)
7394 * get meson-identity corresponding to flavors of q-aq chain
7397 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7398 & ZERO,AMCH1N,1,IDUM)
7400 * change kinematics of chains
7401 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7402 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7403 & AMCH1,AMCH1N,AMCH2,IREJ1)
7404 IF (IREJ1.NE.0) GOTO 10
7405 * check second chain for resonance
7407 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7408 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7409 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7410 IF (IREJ1.NE.0) GOTO 10
7411 IF (IDR2.NE.0) IDR2 = 100*IDR2
7412 * add partons and chains to DTEVT1
7414 PCH1(K) = PP1(K)+PT1(K)
7415 PCH2(K) = PP2(K)+PT2(K)
7417 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7418 & PP1(3),PP1(4),0,0,0)
7419 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7420 & PT1(2),PT1(3),PT1(4),0,0,0)
7421 KCH = ISTHKK(N1+2)+100
7422 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7423 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7425 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7426 & PP2(3),PP2(4),0,0,0)
7427 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7428 & PT2(2),PT2(3),PT2(4),0,0,0)
7429 KCH = ISTHKK(N2+2)+100
7430 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7431 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7447 *$ CREATE DT_PHNSCH.FOR
7450 *=== phnsch ===========================================================*
7452 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7454 *----------------------------------------------------------------------*
7456 * Probability for Hadron Nucleon Single CHain interactions: *
7458 * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7461 * Last change on 04-jan-94 by Alfredo Ferrari *
7463 * modified by J.R.for use in DTUNUC 6.1.94 *
7465 * Input variables: *
7466 * Kp = hadron projectile index (Part numbering *
7468 * Ktarg = target nucleon index (1=proton, 8=neutron) *
7469 * Plab = projectile laboratory momentum (GeV/c) *
7470 * Output variable: *
7471 * Phnsch = probability per single chain (particle *
7472 * exchange) interactions *
7474 *----------------------------------------------------------------------*
7476 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7479 PARAMETER ( LUNOUT = 6 )
7480 PARAMETER ( LUNERR = 6 )
7481 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7482 PARAMETER ( ZERZER = 0.D+00 )
7483 PARAMETER ( ONEONE = 1.D+00 )
7484 PARAMETER ( TWOTWO = 2.D+00 )
7485 PARAMETER ( FIVFIV = 5.D+00 )
7486 PARAMETER ( HLFHLF = 0.5D+00 )
7488 PARAMETER ( NALLWP = 39 )
7489 PARAMETER ( IDMAXP = 210 )
7491 DIMENSION ICHRGE(39),AM(39)
7493 * particle properties (BAMJET index convention)
7495 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7496 & IICH(210),IIBAR(210),K1(210),K2(210)
7498 DIMENSION KPTOIP(210)
7499 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7500 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7501 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7502 & IQTCHR(-6:6),MQUARK(3,39)
7504 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7505 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7506 CPH SAVE SGTCOE, IHLP
7507 CPH SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7508 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7509 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7510 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7512 * Conversion from part to paprop numbering
7513 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7514 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7515 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7517 * 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7518 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7519 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7520 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7522 * 1st reaction: gamma p total
7523 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7524 * 2nd reaction: gamma d total
7525 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7526 * 3rd reaction: pi+ p total
7527 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7528 * 4th reaction: pi- p total
7529 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7530 * 5th reaction: pi+/- d total
7531 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7532 * 6th reaction: K+ p total
7533 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7534 * 7th reaction: K+ n total
7535 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7536 * 8th reaction: K+ d total
7537 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7538 * 9th reaction: K- p total
7539 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7540 * 10th reaction: K- n total
7541 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7542 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7544 * 11th reaction: K- d total
7545 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7546 * 12th reaction: p p total
7547 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7548 * 13th reaction: p n total
7549 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7550 * 14th reaction: p d total
7551 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
7552 * 15th reaction: pbar p total
7553 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
7554 * 16th reaction: pbar n total
7555 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
7556 * 17th reaction: pbar d total
7557 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
7558 * 18th reaction: Lamda p total
7559 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
7560 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7562 * 19th reaction: pi+ p elastic
7563 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
7564 * 20th reaction: pi- p elastic
7565 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
7566 * 21st reaction: K+ p elastic
7567 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
7568 * 22nd reaction: K- p elastic
7569 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
7570 * 23rd reaction: p p elastic
7571 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
7572 * 24th reaction: p d elastic
7573 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
7574 * 25th reaction: pbar p elastic
7575 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
7576 * 26th reaction: pbar p elastic bis
7577 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
7578 * 27th reaction: pbar n elastic
7579 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
7580 * 28th reaction: Lamda p elastic
7581 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
7582 * 29th reaction: K- p ela bis
7583 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
7584 * 30th reaction: pi- p cx
7585 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
7586 * 31st reaction: K- p cx
7587 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
7588 * 32nd reaction: K+ n cx
7589 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
7590 * 33rd reaction: pbar p cx
7591 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
7593 * +-------------------------------------------------------------------*
7594 ICHRGE(KTARG)=IICH(KTARG)
7595 AM (KTARG)=AAM (KTARG)
7596 * | Check for pi0 (d-dbar)
7597 IF ( KP .NE. 26 ) THEN
7603 * +-------------------------------------------------------------------*
7610 * +-------------------------------------------------------------------*
7611 * +-------------------------------------------------------------------*
7612 * | No such interactions for baryon-baryon
7613 IF ( IIBAR (KP) .GT. 0 ) THEN
7617 * +-------------------------------------------------------------------*
7618 * | No "annihilation" diagram possible for K+ p/n
7619 ELSE IF ( IP .EQ. 15 ) THEN
7623 * +-------------------------------------------------------------------*
7624 * | No "annihilation" diagram possible for K0 p/n
7625 ELSE IF ( IP .EQ. 24 ) THEN
7629 * +-------------------------------------------------------------------*
7630 * | No "annihilation" diagram possible for Omebar p/n
7631 ELSE IF ( IP .GE. 38 ) THEN
7636 * +-------------------------------------------------------------------*
7637 * +-------------------------------------------------------------------*
7638 * | If the momentum is larger than 50 GeV/c, compute the single
7639 * | chain probability at 50 GeV/c and extrapolate to the present
7640 * | momentum according to 1/sqrt(s)
7641 * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7642 * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7643 * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7644 * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7646 * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7647 IF ( PLAB .GT. 50.D+00 ) THEN
7650 AMTSQ = AM (KTARG)**2
7651 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7652 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7653 EPROJ = SQRT ( PLA**2 + AMPSQ )
7654 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7655 UMORAT = SQRT ( UMOSQ / UMO50 )
7657 * +-------------------------------------------------------------------*
7659 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7662 AMTSQ = AM (KTARG)**2
7663 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7664 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7665 EPROJ = SQRT ( PLA**2 + AMPSQ )
7666 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7667 UMORAT = SQRT ( UMOSQ / UMO50 )
7669 * +-------------------------------------------------------------------*
7676 * +-------------------------------------------------------------------*
7678 * +-------------------------------------------------------------------*
7680 IF ( IHLP (IP) .EQ. 2 ) THEN
7686 * | Compute the pi+ p total cross section:
7687 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7689 ACOF = SGTCOE (1,19)
7690 BCOF = SGTCOE (2,19)
7691 ENNE = SGTCOE (3,19)
7692 CCOF = SGTCOE (4,19)
7693 DCOF = SGTCOE (5,19)
7694 * | Compute the pi+ p elastic cross section:
7695 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7697 * | Compute the pi+ p inelastic cross section:
7698 SPPPIN = SPPPTT - SPPPEL
7704 * | Compute the pi- p total cross section:
7705 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7707 ACOF = SGTCOE (1,20)
7708 BCOF = SGTCOE (2,20)
7709 ENNE = SGTCOE (3,20)
7710 CCOF = SGTCOE (4,20)
7711 DCOF = SGTCOE (5,20)
7712 * | Compute the pi- p elastic cross section:
7713 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7715 * | Compute the pi- p inelastic cross section:
7716 SPMPIN = SPMPTT - SPMPEL
7717 SIGDIA = SPMPIN - SPPPIN
7718 * | +----------------------------------------------------------------*
7719 * | | Charged pions: besides isospin consideration it is supposed
7720 * | | that (pi+ n)el is almost equal to (pi- p)el
7721 * | | and (pi+ p)el " " " " (pi- n)el
7722 * | | and all are almost equal among each others
7723 * | | (reasonable above 5 GeV/c)
7724 IF ( ICHRGE (IP) .NE. 0 ) THEN
7726 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7727 ACOF = SGTCOE (1,JREAC)
7728 BCOF = SGTCOE (2,JREAC)
7729 ENNE = SGTCOE (3,JREAC)
7730 CCOF = SGTCOE (4,JREAC)
7731 DCOF = SGTCOE (5,JREAC)
7732 * | | Compute the total cross section:
7733 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7735 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7736 ACOF = SGTCOE (1,JREAC)
7737 BCOF = SGTCOE (2,JREAC)
7738 ENNE = SGTCOE (3,JREAC)
7739 CCOF = SGTCOE (4,JREAC)
7740 DCOF = SGTCOE (5,JREAC)
7741 * | | Compute the elastic cross section:
7742 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7744 * | | Compute the inelastic cross section:
7745 SHNCIN = SHNCTT - SHNCEL
7746 * | | Number of diagrams:
7747 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7748 * | | Now compute the chain end (anti)quark-(anti)diquark
7749 IQFSC1 = 1 + IP - 13
7752 IQBSC2 = 1 + IP - 13
7754 * | +----------------------------------------------------------------*
7755 * | | pi0: besides isospin consideration it is supposed that the
7756 * | | elastic cross section is not very different from
7757 * | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
7760 K2HLP = ( KP - 23 ) / 3
7761 * | | Number of diagrams:
7762 * | | For u ubar (k2hlp=0):
7763 * NDIAGR = 2 - KHELP
7764 * | | For d dbar (k2hlp=1):
7765 * NDIAGR = 2 + KHELP - K2HLP
7766 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7767 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7768 * | | Now compute the chain end (anti)quark-(anti)diquark
7775 * | +----------------------------------------------------------------*
7777 * +-------------------------------------------------------------------*
7779 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7785 * | Compute the K+ p total cross section:
7786 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7788 ACOF = SGTCOE (1,21)
7789 BCOF = SGTCOE (2,21)
7790 ENNE = SGTCOE (3,21)
7791 CCOF = SGTCOE (4,21)
7792 DCOF = SGTCOE (5,21)
7793 * | Compute the K+ p elastic cross section:
7794 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7796 * | Compute the K+ p inelastic cross section:
7797 SKPPIN = SKPPTT - SKPPEL
7803 * | Compute the K- p total cross section:
7804 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7806 ACOF = SGTCOE (1,22)
7807 BCOF = SGTCOE (2,22)
7808 ENNE = SGTCOE (3,22)
7809 CCOF = SGTCOE (4,22)
7810 DCOF = SGTCOE (5,22)
7811 * | Compute the K- p elastic cross section:
7812 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7814 * | Compute the K- p inelastic cross section:
7815 SKMPIN = SKMPTT - SKMPEL
7816 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7817 * | +----------------------------------------------------------------*
7818 * | | Charged Kaons: actually only K-
7819 IF ( ICHRGE (IP) .NE. 0 ) THEN
7821 * | | +-------------------------------------------------------------*
7822 * | | | Proton target:
7823 IF ( KHELP .EQ. 0 ) THEN
7825 * | | | Number of diagrams:
7828 * | | +-------------------------------------------------------------*
7829 * | | | Neutron target: besides isospin consideration it is supposed
7830 * | | | that (K- n)el is almost equal to (K- p)el
7831 * | | | (reasonable above 5 GeV/c)
7833 ACOF = SGTCOE (1,10)
7834 BCOF = SGTCOE (2,10)
7835 ENNE = SGTCOE (3,10)
7836 CCOF = SGTCOE (4,10)
7837 DCOF = SGTCOE (5,10)
7838 * | | | Compute the total cross section:
7839 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7841 * | | | Compute the elastic cross section:
7843 * | | | Compute the inelastic cross section:
7844 SHNCIN = SHNCTT - SHNCEL
7845 * | | | Number of diagrams:
7849 * | | +-------------------------------------------------------------*
7850 * | | Now compute the chain end (anti)quark-(anti)diquark
7856 * | +----------------------------------------------------------------*
7857 * | | K0's: (actually only K0bar)
7860 * | | +-------------------------------------------------------------*
7861 * | | | Proton target: (K0bar p)in supposed to be given by
7862 * | | | (K- p)in - Sig_diagr
7863 IF ( KHELP .EQ. 0 ) THEN
7864 SHNCIN = SKMPIN - SIGDIA
7865 * | | | Number of diagrams:
7868 * | | +-------------------------------------------------------------*
7869 * | | | Neutron target: (K0bar n)in supposed to be given by
7870 * | | | (K- n)in + Sig_diagr
7871 * | | | besides isospin consideration it is supposed
7872 * | | | that (K- n)el is almost equal to (K- p)el
7873 * | | | (reasonable above 5 GeV/c)
7875 ACOF = SGTCOE (1,10)
7876 BCOF = SGTCOE (2,10)
7877 ENNE = SGTCOE (3,10)
7878 CCOF = SGTCOE (4,10)
7879 DCOF = SGTCOE (5,10)
7880 * | | | Compute the total cross section:
7881 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7883 * | | | Compute the elastic cross section:
7885 * | | | Compute the inelastic cross section:
7886 SHNCIN = SHNCTT - SHNCEL + SIGDIA
7887 * | | | Number of diagrams:
7891 * | | +-------------------------------------------------------------*
7892 * | | Now compute the chain end (anti)quark-(anti)diquark
7899 * | +----------------------------------------------------------------*
7901 * +-------------------------------------------------------------------*
7903 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7904 * | For momenta between 3 and 5 GeV/c the use of tabulated data
7905 * | should be implemented!
7906 ACOF = SGTCOE (1,15)
7907 BCOF = SGTCOE (2,15)
7908 ENNE = SGTCOE (3,15)
7909 CCOF = SGTCOE (4,15)
7910 DCOF = SGTCOE (5,15)
7911 * | Compute the pbar p total cross section:
7912 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7914 IF ( PLA .LT. FIVFIV ) THEN
7919 ACOF = SGTCOE (1,JREAC)
7920 BCOF = SGTCOE (2,JREAC)
7921 ENNE = SGTCOE (3,JREAC)
7922 CCOF = SGTCOE (4,JREAC)
7923 DCOF = SGTCOE (5,JREAC)
7924 * | Compute the pbar p elastic cross section:
7925 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7927 * | Compute the pbar p inelastic cross section:
7928 SAPPIN = SAPPTT - SAPPEL
7929 ACOF = SGTCOE (1,12)
7930 BCOF = SGTCOE (2,12)
7931 ENNE = SGTCOE (3,12)
7932 CCOF = SGTCOE (4,12)
7933 DCOF = SGTCOE (5,12)
7934 * | Compute the p p total cross section:
7935 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7937 ACOF = SGTCOE (1,23)
7938 BCOF = SGTCOE (2,23)
7939 ENNE = SGTCOE (3,23)
7940 CCOF = SGTCOE (4,23)
7941 DCOF = SGTCOE (5,23)
7942 * | Compute the p p elastic cross section:
7943 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7945 * | Compute the K- p inelastic cross section:
7946 SPPINE = SPPTOT - SPPELA
7947 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7949 * | +----------------------------------------------------------------*
7951 IF ( ICHRGE (IP) .NE. 0 ) THEN
7953 * | | +-------------------------------------------------------------*
7954 * | | | Proton target:
7955 IF ( KHELP .EQ. 0 ) THEN
7956 * | | | Number of diagrams:
7960 * | | +-------------------------------------------------------------*
7961 * | | | Neutron target: it is supposed that (ap n)el is almost equal
7962 * | | | to (ap p)el (reasonable above 5 GeV/c)
7964 ACOF = SGTCOE (1,16)
7965 BCOF = SGTCOE (2,16)
7966 ENNE = SGTCOE (3,16)
7967 CCOF = SGTCOE (4,16)
7968 DCOF = SGTCOE (5,16)
7969 * | | | Compute the total cross section:
7970 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7972 * | | | Compute the elastic cross section:
7974 * | | | Compute the inelastic cross section:
7975 SHNCIN = SHNCTT - SHNCEL
7979 * | | +-------------------------------------------------------------*
7980 * | | Now compute the chain end (anti)quark-(anti)diquark
7981 * | | there are different possibilities, make a random choiche:
7983 RNCHEN = DT_RNDM(PUUBAR)
7984 IF ( RNCHEN .LT. PUUBAR ) THEN
7989 IQBSC1 = -IQFSC1 + KHELP
7992 * | +----------------------------------------------------------------*
7996 * | | +-------------------------------------------------------------*
7997 * | | | Proton target: (nbar p)in supposed to be given by
7998 * | | | (pbar p)in - Sig_diagr
7999 IF ( KHELP .EQ. 0 ) THEN
8000 SHNCIN = SAPPIN - SIGDIA
8003 * | | +-------------------------------------------------------------*
8004 * | | | Neutron target: (nbar n)el is supposed to be equal to
8005 * | | | (pbar p)el (reasonable above 5 GeV/c)
8007 * | | | Compute the total cross section:
8009 * | | | Compute the elastic cross section:
8011 * | | | Compute the inelastic cross section:
8012 SHNCIN = SHNCTT - SHNCEL
8016 * | | +-------------------------------------------------------------*
8017 * | | Now compute the chain end (anti)quark-(anti)diquark
8018 * | | there are different possibilities, make a random choiche:
8020 RNCHEN = DT_RNDM(RNCHEN)
8021 IF ( RNCHEN .LT. PDDBAR ) THEN
8026 IQBSC1 = -IQFSC1 + KHELP - 1
8030 * | +----------------------------------------------------------------*
8032 * +-------------------------------------------------------------------*
8033 * | Others: not yet implemented
8042 * +-------------------------------------------------------------------*
8043 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8044 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8046 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8050 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8052 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8053 & + IQSCHR (MQUARK(3,IP))
8054 * +-------------------------------------------------------------------*
8055 * | Consistency check:
8056 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8057 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8058 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8059 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8060 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8061 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8062 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8065 * +-------------------------------------------------------------------*
8066 * +-------------------------------------------------------------------*
8067 * | Consistency check:
8068 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8069 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8071 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8072 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8074 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8075 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8078 * +-------------------------------------------------------------------*
8079 * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8080 IF ( UMORAT .GT. ONEPLS )
8081 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8082 & - ONEONE ) * UMORAT + ONEONE )
8085 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8091 *=== End of function Phnsch ===========================================*
8095 *$ CREATE DT_RESPT.FOR
8098 *===respt==============================================================*
8102 ************************************************************************
8103 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8104 * This version dated 18.01.95 is written by S. Roesler *
8105 ************************************************************************
8107 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8109 PARAMETER ( LINP = 10 ,
8112 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8115 PARAMETER (NMXHKK=200000)
8116 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8117 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8118 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8119 * extended event history
8120 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8121 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8124 * get index of first chain
8125 DO 1 I=NPOINT(3),NHKK
8126 IF (IDHKK(I).EQ.88888) THEN
8133 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8134 C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8135 * skip VV-,SS- systems
8136 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8137 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8138 * check if both "chains" are resonances
8139 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8140 CALL DT_SAPTRE(NC,NC+3)
8154 *$ CREATE DT_EVTRES.FOR
8157 *===evtres=============================================================*
8159 SUBROUTINE DT_EVTRES(IREJ)
8161 ************************************************************************
8162 * This version dated 14.12.94 is written by S. Roesler *
8163 ************************************************************************
8165 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8167 PARAMETER ( LINP = 10 ,
8170 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8173 PARAMETER (NMXHKK=200000)
8174 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8175 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8176 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8177 * extended event history
8178 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8179 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8181 * flags for input different options
8182 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8183 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8184 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8185 * particle properties (BAMJET index convention)
8187 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8188 & IICH(210),IIBAR(210),K1(210),K2(210)
8190 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8194 DO 1 I=NPOINT(3),NHKK
8195 IF (ABS(IDRES(I)).GE.100) THEN
8197 DO 2 J=NPOINT(3),NHKK
8198 IF (IDHKK(J).EQ.88888) THEN
8199 IF (PHKK(5,J).GT.AMMX) THEN
8205 IF (IDRES(IMMX).NE.0) THEN
8206 IF (IOULEV(3).GT.0) THEN
8207 WRITE(LOUT,'(1X,A)')
8208 & 'EVTRES: no chain for correc. found'
8217 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8221 IMO21 = JMOHKK(1,IMMX)
8222 IMO22 = JMOHKK(2,IMMX)
8223 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8224 IMO21 = JMOHKK(2,IMMX)
8225 IMO22 = JMOHKK(1,IMMX)
8228 AMCH1N = AAM(IDXRES(I))
8230 IFPR1 = IDHKK(IMO11)
8231 IFPR2 = IDHKK(IMO21)
8232 IFTA1 = IDHKK(IMO12)
8233 IFTA2 = IDHKK(IMO22)
8235 PP1(J) = PHKK(J,IMO11)
8236 PP2(J) = PHKK(J,IMO21)
8237 PT1(J) = PHKK(J,IMO12)
8238 PT2(J) = PHKK(J,IMO22)
8240 * store initial configuration for energy-momentum cons. check
8241 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8242 * correct kinematics of second chain
8243 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8244 & AMCH1,AMCH1N,AMCH2,IREJ1)
8245 IF (IREJ1.NE.0) GOTO 9999
8246 * check now this chain for resonance mass
8247 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8249 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8250 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8252 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8254 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8255 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8256 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8257 & AMCH2,AMCH2N,IDCH2,IREJ1)
8258 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8260 & WRITE(LOUT,*) ' correction for resonance not poss.'
8266 * store final configuration for energy-momentum cons. check
8268 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8269 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8270 IF (IREJ1.NE.0) GOTO 9999
8273 PHKK(J,IMO11) = PP1(J)
8274 PHKK(J,IMO21) = PP2(J)
8275 PHKK(J,IMO12) = PT1(J)
8276 PHKK(J,IMO22) = PT2(J)
8278 * correct entries of chains
8280 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8281 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8283 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8284 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8286 * ?? the following should now be obsolete
8288 C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8289 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8291 WRITE(LOUT,'(1X,A,4G10.3)')
8292 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8296 PHKK(5,I) = SQRT(AM1)
8297 PHKK(5,IMMX) = SQRT(AM2)
8298 IDRES(I) = IDRES(I)/100
8299 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8300 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8301 WRITE(LOUT,'(1X,A,4G10.3)')
8302 & 'EVTRES: inconsistent chain-masses',
8303 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8316 *$ CREATE DT_GETSPT.FOR
8319 *===getspt=============================================================*
8321 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8322 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8323 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8325 ************************************************************************
8326 * This version dated 12.12.94 is written by S. Roesler *
8327 ************************************************************************
8329 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8331 PARAMETER ( LINP = 10 ,
8334 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8336 * various options for treatment of partons (DTUNUC 1.x)
8337 * (chain recombination, Cronin,..)
8338 LOGICAL LCO2CR,LINTPT
8339 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8341 * flags for input different options
8342 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8343 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8344 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8345 * flags for diffractive interactions (DTUNUC 1.x)
8346 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8348 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8349 & PT2(4),PT2I(4),P1(4),P2(4),
8350 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8351 & PTOTI(4),PTOTF(4),DIFF(4)
8357 C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8358 C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8364 IF (IDIFF.NE.0) THEN
8370 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8376 * get initial chain masses
8377 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8378 & +(PP1(3)+PT1(3))**2)
8380 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8381 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8382 & +(PP2(3)+PT2(3))**2)
8384 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8385 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8387 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8397 C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8401 C IF (AM1.LT.0.6) THEN
8403 C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8406 C IF (AM2.LT.0.6) THEN
8408 C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8413 * check chain masses for very low mass chains
8414 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8415 C & AM1,DUM,-IDCH1,IREJ1)
8416 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8417 C & AM2,DUM,-IDCH2,IREJ2)
8418 C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8427 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8428 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8429 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8430 C IF (MOD(IC,19).EQ.0) JMSHL = 0
8431 IF (MOD(IC,20).EQ.0) GOTO 7
8432 C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8437 * get transverse momentum
8439 ES = -2.0D0/(B33P**2)
8440 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8441 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8443 ES = -2.0D0/(B33T**2)
8444 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8445 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8451 CALL DT_DSFECF(SFE1,CFE1)
8452 CALL DT_DSFECF(SFE2,CFE2)
8454 PP1(1) = PP1I(1)+HPSP*CFE1
8455 PP1(2) = PP1I(2)+HPSP*SFE1
8456 PP2(1) = PP2I(1)-HPSP*CFE1
8457 PP2(2) = PP2I(2)-HPSP*SFE1
8458 PT1(1) = PT1I(1)+HPST*CFE2
8459 PT1(2) = PT1I(2)+HPST*SFE2
8460 PT2(1) = PT2I(1)-HPST*CFE2
8461 PT2(2) = PT2I(2)-HPST*SFE2
8463 PP1(1) = PP1I(1)+HPSP*CFE1
8464 PP1(2) = PP1I(2)+HPSP*SFE1
8465 PT1(1) = PT1I(1)-HPSP*CFE1
8466 PT1(2) = PT1I(2)-HPSP*SFE1
8467 PP2(1) = PP2I(1)+HPST*CFE2
8468 PP2(2) = PP2I(2)+HPST*SFE2
8469 PT2(1) = PT2I(1)-HPST*CFE2
8470 PT2(2) = PT2I(2)-HPST*SFE2
8473 * put partons on mass shell
8476 IF (JMSHL.EQ.1) THEN
8477 XMP1 = PYMASS(IFPR1)
8478 XMT1 = PYMASS(IFTA1)
8480 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8481 IF (IREJ1.NE.0) GOTO 2
8483 PTOTF(I) = P1(I)+P2(I)
8489 IF (JMSHL.EQ.1) THEN
8490 XMP2 = PYMASS(IFPR2)
8491 XMT2 = PYMASS(IFTA2)
8493 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8494 IF (IREJ1.NE.0) GOTO 2
8496 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8503 DIFF(I) = PTOTI(I)-PTOTF(I)
8505 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8506 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8507 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8510 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8511 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8512 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8513 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8514 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8515 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8516 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8517 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8518 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8519 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8521 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8522 & 'GETSPT: inconsistent masses',
8523 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8524 * sr 22.11.00: commented. It should only have inconsistent masses for
8525 * ultrahigh energies due to rounding problems
8530 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8531 & +(PP1(3)+PT1(3))**2)
8533 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
8534 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8535 & +(PP2(3)+PT2(3))**2)
8537 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
8538 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8540 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8547 * check chain masses for very low mass chains
8548 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8549 & AM1N,DUM,-IDCH1,IREJ1)
8550 IF (IREJ1.NE.0) GOTO 2
8551 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8552 & AM2N,DUM,-IDCH2,IREJ2)
8553 IF (IREJ2.NE.0) GOTO 2
8556 IF (AM1N.GT.ZERO) THEN
8574 *$ CREATE DT_SAPTRE.FOR
8577 *===saptre=============================================================*
8579 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8581 ************************************************************************
8582 * p-t sampling for two-resonance systems. ("BAMJET-like" method) *
8583 * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
8584 * Adopted from the original SAPTRE written by J. Ranft. *
8585 * This version dated 18.01.95 is written by S. Roesler *
8586 ************************************************************************
8588 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8590 PARAMETER ( LINP = 10 ,
8593 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8596 PARAMETER (NMXHKK=200000)
8597 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8598 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8599 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8600 * extended event history
8601 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8602 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8604 * flags for input different options
8605 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8606 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8607 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8609 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8613 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8614 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8615 ESMAX = MIN(ESMAX1,ESMAX2)
8616 IF (ESMAX.LE.0.05D0) RETURN
8620 PA1(K) = PHKK(K,IDX1)
8621 PA2(K) = PHKK(K,IDX2)
8625 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8626 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8630 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8631 BEXP = HMA*(1.0D0-EXEB)/B3
8632 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8633 WA = AXEXP/(BEXP+AXEXP)
8636 * ES is the transverse kinetic energy
8640 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8643 ES = ABS(-LOG(X+TINY7)/B3)
8645 IF (ES.GT.ESMAX) GOTO 10
8647 * transverse momentum
8648 HPS = SQRT((ES-HMA)*(ES+HMA))
8650 CALL DT_DSFECF(SFE,CFE)
8653 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8654 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8655 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8657 C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8658 C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8664 * put resonances on mass-shell again
8667 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8668 IF (IREJ1.NE.0) RETURN
8671 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8672 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8673 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8674 IF (IREJ1.NE.0) RETURN
8678 PHKK(K,IDX1) = P1(K)
8679 PHKK(K,IDX2) = P2(K)
8685 *$ CREATE DT_CRONIN.FOR
8688 *===cronin=============================================================*
8690 SUBROUTINE DT_CRONIN(INCL)
8692 ************************************************************************
8693 * Cronin-Effect. Multiple scattering of partons at chain ends. *
8694 * INCL = 1 multiple sc. in projectile *
8695 * = 2 multiple sc. in target *
8696 * This version dated 05.01.96 is written by S. Roesler. *
8697 ************************************************************************
8699 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8701 PARAMETER ( LINP = 10 ,
8704 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8707 PARAMETER (NMXHKK=200000)
8708 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8709 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8710 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8711 * extended event history
8712 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8713 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8716 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8717 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8718 & IREXCI(3),IRDIFF(2),IRINC
8719 * Glauber formalism: collision properties
8720 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8721 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8723 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8729 DO 2 I=NPOINT(2),NHKK
8730 IF (ISTHKK(I).LT.0) THEN
8731 * get z-position of the chain
8732 R(1) = VHKK(1,I)*1.0D12
8733 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8734 R(2) = VHKK(2,I)*1.0D12
8736 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8737 & IDXNU = JMOHKK(1,I-1)
8738 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8739 & IDXNU = JMOHKK(1,I+1)
8740 R(3) = VHKK(3,IDXNU)*1.0D12
8741 * position of target parton the chain is connected to
8745 * multiple scattering of parton with DTEVT1-index I
8746 CALL DT_CROMSC(PIN,R,POUT,INCL)
8748 C IF (NEVHKK.EQ.5) THEN
8749 C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8750 C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8751 C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8752 C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8753 C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8754 C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
8755 C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
8758 * increase accumulator by energy-momentum difference
8760 DEV(K) = DEV(K)+POUT(K)-PIN(K)
8763 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8764 & PHKK(2,I)**2-PHKK(3,I)**2))
8768 * dump accumulator to momenta of valence partons
8771 DO 5 I=NPOINT(2),NHKK
8772 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8774 ETOT = ETOT+PHKK(4,I)
8777 C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8778 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
8780 DO 6 I=NPOINT(2),NHKK
8781 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8784 C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8785 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8787 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8788 & PHKK(2,I)**2-PHKK(3,I)**2))
8795 *$ CREATE DT_CROMSC.FOR
8798 *===cromsc=============================================================*
8800 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8802 ************************************************************************
8803 * Cronin-Effect. Multiple scattering of one parton passing through *
8805 * PIN(4) input 4-momentum of parton *
8806 * POUT(4) 4-momentum of parton after mult. scatt. *
8807 * R(3) spatial position of parton in target nucleus *
8808 * INCL = 1 multiple sc. in projectile *
8809 * = 2 multiple sc. in target *
8810 * This is a revised version of the original version written by J. Ranft*
8811 * This version dated 17.01.95 is written by S. Roesler. *
8812 ************************************************************************
8814 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8816 PARAMETER ( LINP = 10 ,
8819 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8824 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8825 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8826 & IREXCI(3),IRDIFF(2),IRINC
8827 * Glauber formalism: collision properties
8828 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8829 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8830 * various options for treatment of partons (DTUNUC 1.x)
8831 * (chain recombination, Cronin,..)
8832 LOGICAL LCO2CR,LINTPT
8833 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8836 DIMENSION PIN(4),POUT(4),R(3)
8838 DATA LSTART /.TRUE./
8840 IRCRON(1) = IRCRON(1)+1
8843 WRITE(LOUT,1000) CRONCO
8844 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
8845 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8851 IF (INCL.EQ.2) RNCL = RTARG
8853 * Lorentz-transformation into Lab.
8855 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8857 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8858 IF (PTOT.LE.8.0D0) GOTO 9997
8860 * direction cosines of parton before mult. scattering
8865 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8866 IF (RTESQ.GE.-TINY3) GOTO 9999
8868 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8869 * in the direction of particle motion
8871 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8873 IF (TMP.LT.ZERO) GOTO 9998
8876 * multiple scattering angle
8877 THETO = CRONCO*SQRT(DIST)/PTOT
8878 IF (THETO.GT.0.1D0) THETO=0.1D0
8881 * Gaussian sampling of spatial angle
8882 CALL DT_RANNOR(R1,R2)
8883 THETA = ABS(R1*THETO)
8884 IF (THETA.GT.0.3D0) GOTO 9997
8885 CALL DT_DSFECF(SFE,CFE)
8889 * new direction cosines
8890 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8891 & COSXN,COSYN,COSZN)
8893 POUT(1) = COSXN*PTOT
8894 POUT(2) = COSYN*PTOT
8896 * Lorentz-transformation into nucl.-nucl. cms
8898 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8900 C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8901 C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8902 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8905 IF (MOD(NCBACK,200).EQ.0) THEN
8906 WRITE(LOUT,1001) THETO,PIN,POUT
8907 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8908 & E12.4,/,1X,' PIN :',4E12.4,/,
8909 & 1X,' POUT:',4E12.4)
8917 9997 IRCRON(2) = IRCRON(2)+1
8919 9998 IRCRON(3) = IRCRON(3)+1
8928 *$ CREATE DT_COM2CR.FOR
8931 *===com2sr=============================================================*
8933 SUBROUTINE DT_COM2CR
8935 ************************************************************************
8936 * COMbine q-aq chains to Color Ropes (qq-aqaq). *
8937 * CUTOF parameter determining minimum number of not *
8938 * combined q-aq chains *
8939 * This subroutine replaces KKEVCC etc. *
8940 * This version dated 11.01.95 is written by S. Roesler. *
8941 ************************************************************************
8943 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8945 PARAMETER ( LINP = 10 ,
8950 PARAMETER (NMXHKK=200000)
8951 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8952 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8953 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8954 * extended event history
8955 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8956 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8959 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8960 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8962 * various options for treatment of partons (DTUNUC 1.x)
8963 * (chain recombination, Cronin,..)
8964 LOGICAL LCO2CR,LINTPT
8965 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8968 DIMENSION IDXQA(248),IDXAQ(248)
8970 ICCHAI(1,9) = ICCHAI(1,9)+1
8973 * scan DTEVT1 for q-aq, aq-q chains
8974 DO 10 I=NPOINT(3),NHKK
8975 * skip "chains" which are resonances
8976 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8979 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8980 * q-aq, aq-q chain found, keep index
8981 IF (IDHKK(MO1).GT.0) THEN
8992 * minimum number of q-aq chains requested for the same projectile/
8994 NCHMIN = IDT_NPOISS(CUTOF)
8996 * combine q-aq chains of the same projectile
8997 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
8998 * combine q-aq chains of the same target
8999 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9000 * combine aq-q chains of the same projectile
9001 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9002 * combine aq-q chains of the same target
9003 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9008 *$ CREATE DT_SCN4CR.FOR
9011 *===scn4cr=============================================================*
9013 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9015 ************************************************************************
9016 * SCan q-aq chains for Color Ropes. *
9017 * This version dated 11.01.95 is written by S. Roesler. *
9018 ************************************************************************
9020 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9022 PARAMETER ( LINP = 10 ,
9027 PARAMETER (NMXHKK=200000)
9028 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9029 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9030 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9031 * extended event history
9032 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9033 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9036 DIMENSION IDXCH(248),IDXJN(248)
9039 IF (IDXCH(I).GT.0) THEN
9041 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9045 IF (IDXCH(J).GT.0) THEN
9046 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9047 IF (IDXMO.EQ.IDXMO1) THEN
9054 IF (NJOIN.GE.NCHMIN+2) THEN
9055 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9057 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9058 IF (IREJ1.NE.0) GOTO 3
9060 IDXCH(IDXJN(J+1)) = 0
9069 *$ CREATE DT_JOIN.FOR
9072 *===join===============================================================*
9074 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9076 ************************************************************************
9077 * This subroutine joins two q-aq chains to one qq-aqaq chain. *
9078 * IDX1, IDX2 DTEVT1 indices of chains to be joined *
9079 * This version dated 11.01.95 is written by S. Roesler. *
9080 ************************************************************************
9082 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9084 PARAMETER ( LINP = 10 ,
9089 PARAMETER (NMXHKK=200000)
9090 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9091 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9092 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9093 * extended event history
9094 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9095 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9097 * flags for input different options
9098 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9099 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9100 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9102 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9103 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9106 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9114 MO(I,J) = JMOHKK(J,IDX(I))
9115 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9120 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9121 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9122 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9123 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9124 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9126 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9127 & 2I5,' chain ',I4,':',2I5)
9132 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9133 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9135 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9136 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9137 IST1 = ISTHKK(MO(1,1))
9138 IST2 = ISTHKK(MO(1,2))
9140 * put partons again on mass shell
9143 IF (IMSHL.EQ.1) THEN
9147 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9148 IF (IREJ1.NE.0) GOTO 9999
9154 * store new partons in DTEVT1
9155 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9157 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9160 PCH(K) = PP(K)+PT(K)
9163 * check new chain for lower mass limit
9164 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9165 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9166 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9167 & AMCH,AMCHN,3,IREJ1)
9168 IF (IREJ1.NE.0) THEN
9174 ICCHAI(2,9) = ICCHAI(2,9)+1
9175 * store new chain in DTEVT1
9177 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9178 IDHKK(IDX(1)) = 22222
9179 IDHKK(IDX(2)) = 22222
9180 * special treatment for space-time coordinates
9182 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9183 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9192 *$ CREATE DT_XSGLAU.FOR
9195 *===xsglau=============================================================*
9197 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9199 ************************************************************************
9200 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9201 * Glauber's approach. *
9202 * NA / NB mass numbers of proj./target nuclei *
9203 * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9204 * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9205 * IE,IQ indices of energy and virtuality (the latter for gamma *
9206 * projectiles only) *
9207 * NIDX index of projectile/target nucleus *
9208 * This version dated 17.3.98 is written by S. Roesler *
9209 ************************************************************************
9211 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9213 PARAMETER ( LINP = 10 ,
9217 COMPLEX*16 CZERO,CONE,CTWO
9219 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9220 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9221 PARAMETER (TWOPI = 6.283185307179586454D+00,
9223 & GEV2MB = 0.38938D0,
9224 & GEV2FM = 0.1972D0,
9225 & ALPHEM = ONE/137.0D0,
9229 * approx. nucleon radius
9232 * particle properties (BAMJET index convention)
9234 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9235 & IICH(210),IIBAR(210),K1(210),K2(210)
9236 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9237 PARAMETER ( MAXNCL = 260,
9239 & MAXSQU = 20*MAXVQU,
9240 & MAXINT = MAXVQU+MAXSQU)
9241 * Glauber formalism: parameters
9242 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9243 & BMAX(NCOMPX),BSTEP(NCOMPX),
9244 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9246 * Glauber formalism: cross sections
9247 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9248 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9249 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9250 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9251 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9252 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9253 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9254 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9255 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9256 & BSLOPE,NEBINI,NQBINI
9257 * Glauber formalism: flags and parameters for statistics
9260 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9261 * nucleon-nucleon event-generator
9264 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9265 * VDM parameter for photon-nucleus interactions
9266 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9267 * parameters for hA-diffraction
9268 COMMON /DTDIHA/ DIBETA,DIALPH
9270 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9271 & OMPP11,OMPP12,OMPP21,OMPP22,
9272 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9275 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9276 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9279 PARAMETER (NPOINT=16)
9280 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9282 LOGICAL LFIRST,LOPEN
9283 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9286 * for quasi-elastic neutrino scattering set projectile to proton
9287 * it should not have an effect since the whole Glauber-formalism is
9288 * not needed for these interactions..
9289 IF (MCGENE.EQ.4) THEN
9295 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9298 CFILE = CGLB//'.glb'
9299 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9300 ELSEIF (I.GT.1) THEN
9301 CFILE = CGLB(1:I-1)//'.glb'
9302 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9309 CZERO = DCMPLX(ZERO,ZERO)
9310 CONE = DCMPLX(ONE,ZERO)
9311 CTWO = DCMPLX(TWO,ZERO)
9315 * re-define kinematics
9319 * g(Q2=0)-A, h-A, A-A scattering
9320 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9323 * g(Q2>0)-A scattering
9324 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9326 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9327 Q2 = (S-AMP2)*X/(ONE-X)
9328 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9329 S = Q2*(ONE-X)/X+AMP2
9331 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9336 XNU = (S+Q2-AMP2)/(TWO*AMP)
9338 * parameters determining statistics in evaluating Glauber-xsection
9341 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9343 * set up interaction geometry (common /DTGLAM/)
9344 * projectile/target radii
9345 RPRNCL = DT_RNCLUS(NA)
9346 RTANCL = DT_RNCLUS(NB)
9347 IF (IJPROJ.EQ.7) THEN
9349 RBSH(NTARG) = RTANCL
9350 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9352 IF (NIDX.LE.-1) THEN
9354 RBSH(NTARG) = RTANCL
9355 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9357 RASH(NTARG) = RPRNCL
9359 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9362 * maximum impact-parameter
9363 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9365 * slope, rho ( Re(f(0))/Im(f(0)) )
9366 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9367 IF (MCGENE.EQ.2) THEN
9369 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9372 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9374 IF (ECMNN(IE).LE.3.0D0) THEN
9376 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9377 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9378 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9381 ELSEIF (IJPROJ.EQ.7) THEN
9384 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9388 * projectile-nucleon xsection (in fm)
9389 IF (IJPROJ.EQ.7) THEN
9390 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9392 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9393 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9394 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9396 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9397 SIGSH = SIGSH/10.0D0
9400 * parameters for projectile diffraction (hA scattering only)
9401 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9402 & .AND.(DIBETA.GE.ZERO)) THEN
9404 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9405 C DIBETA = SDIF1/STOT
9407 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9408 IF (DIBETA.LE.ZERO) THEN
9411 ALPGAM = DIALPH/DIGAMM
9415 FACDI = SQRT(FACDI1*FACDI2)
9416 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9428 BSITE( 0,IQ,NTARG,I) = ZERO
9429 BSITE(IE,IQ,NTARG,I) = ZERO
9448 FACN = ONE/DBLE(NSTATB)
9453 * initialize Gauss-integration for photon-proj.
9455 IF (IJPROJ.EQ.7) THEN
9456 IF (INTRGE(1).EQ.1) THEN
9457 AMLO2 = (3.0D0*AAM(13))**2
9458 ELSEIF (INTRGE(1).EQ.2) THEN
9463 IF (INTRGE(2).EQ.1) THEN
9465 ELSEIF (INTRGE(2).EQ.2) THEN
9470 AMHI20 = (ECMNN(IE)-AMP)**2
9471 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9472 XAMLO = LOG( AMLO2+Q2 )
9473 XAMHI = LOG( AMHI2+Q2 )
9475 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9477 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9480 * ratio direct/total photon-nucleon xsection
9481 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9484 * read pre-initialized profile-function from file
9485 IF (IOGLB.EQ.1) THEN
9486 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9487 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9488 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9489 & NA,NB,NSTATB,NSITEB
9490 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9491 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9492 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
9495 IF (LFIRST) WRITE(LOUT,1001) CFILE
9496 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9498 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9499 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9500 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9501 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9502 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9503 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9504 NLINES = INT(DBLE(NSITEB)/7.0D0)
9505 IF (NLINES.GT.0) THEN
9508 READ(LDAT,'(7E11.4)')
9509 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9513 IF (ISTART.LE.NSITEB) THEN
9514 READ(LDAT,'(7E11.4)')
9515 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9519 * variable projectile/target/energy runs:
9520 * read pre-initialized profile-functions from file
9521 ELSEIF (IOGLB.EQ.100) THEN
9522 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9526 * cross sections averaged over NSTATB nucleon configurations
9528 C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9538 IF (NIDX.LE.-1) THEN
9539 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9540 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9541 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9542 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9543 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9546 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9547 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9548 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9549 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9550 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9554 * integration over impact parameter B
9565 B = DBLE(IB)*BSTEP(NTARG)
9566 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
9568 * integration over M_V^2 for photon-proj.
9574 IF (IJPROJ.EQ.7) THEN
9586 IF (IJPROJ.EQ.7) THEN
9587 AMV2 = EXP(ABSZX(IM))-Q2
9589 IF (AMV2.LT.16.0D0) THEN
9591 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9596 * define M_V dependent properties of nucleon scattering amplitude
9597 * V_M-nucleon xsection
9598 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9599 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9600 * slope-parametrisation a la Kaidalov
9601 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9602 & +0.25D0*LOG(S/(AMV2+Q2)))
9604 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9605 * integration weight factor
9606 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9607 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9609 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9611 IF (IJPROJ.EQ.7) THEN
9612 RCA = GAM*SIGMV/TWOPI
9614 RCA = GAM*SIGSH/TWOPI
9617 CA = DCMPLX(RCA,FCA)
9626 * photon-projectile: check for supression by coherence length
9627 IF (IJPROJ.EQ.7) THEN
9628 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9632 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9638 X11 = B+COOT1(1,INB)-COOP1(1,INA)
9639 Y11 = COOT1(2,INB)-COOP1(2,INA)
9640 XY11 = GAM*(X11*X11+Y11*Y11)
9641 IF (XY11.LE.15.0D0) THEN
9642 C = CONE-CA*EXP(-XY11)
9643 AR = DBLE(PP11(INT1))
9644 AI = DIMAG(PP11(INT1))
9645 IF (ABS(AR).LT.TINY25) AR = ZERO
9646 IF (ABS(AI).LT.TINY25) AI = ZERO
9647 PP11(INT1) = DCMPLX(AR,AI)
9648 PP11(INT1) = PP11(INT1)*C
9651 SHI = SHI+LOG(AR*AR+AI*AI)
9653 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9654 X12 = B+COOT2(1,INB)-COOP1(1,INA)
9655 Y12 = COOT2(2,INB)-COOP1(2,INA)
9656 XY12 = GAM*(X12*X12+Y12*Y12)
9657 IF (XY12.LE.15.0D0) THEN
9658 C = CONE-CA*EXP(-XY12)
9659 AR = DBLE(PP12(INT2))
9660 AI = DIMAG(PP12(INT2))
9661 IF (ABS(AR).LT.TINY25) AR = ZERO
9662 IF (ABS(AI).LT.TINY25) AI = ZERO
9663 PP12(INT2) = DCMPLX(AR,AI)
9664 PP12(INT2) = PP12(INT2)*C
9666 X21 = B+COOT1(1,INB)-COOP2(1,INA)
9667 Y21 = COOT1(2,INB)-COOP2(2,INA)
9668 XY21 = GAM*(X21*X21+Y21*Y21)
9669 IF (XY21.LE.15.0D0) THEN
9670 C = CONE-CA*EXP(-XY21)
9671 AR = DBLE(PP21(INT1))
9672 AI = DIMAG(PP21(INT1))
9673 IF (ABS(AR).LT.TINY25) AR = ZERO
9674 IF (ABS(AI).LT.TINY25) AI = ZERO
9675 PP21(INT1) = DCMPLX(AR,AI)
9676 PP21(INT1) = PP21(INT1)*C
9678 X22 = B+COOT2(1,INB)-COOP2(1,INA)
9679 Y22 = COOT2(2,INB)-COOP2(2,INA)
9680 XY22 = GAM*(X22*X22+Y22*Y22)
9681 IF (XY22.LE.15.0D0) THEN
9682 C = CONE-CA*EXP(-XY22)
9683 AR = DBLE(PP22(INT2))
9684 AI = DIMAG(PP22(INT2))
9685 IF (ABS(AR).LT.TINY25) AR = ZERO
9686 IF (ABS(AI).LT.TINY25) AI = ZERO
9687 PP22(INT2) = DCMPLX(AR,AI)
9688 PP22(INT2) = PP22(INT2)*C
9699 IF (PP11(K).EQ.CZERO) THEN
9703 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9704 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9707 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9708 OMPP11 = OMPP11+AVDIPP
9709 C OMPP11 = OMPP11+(CONE-PP11(K))
9710 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9711 DIPP11 = DIPP11+AVDIPP
9712 IF (PP21(K).EQ.CZERO) THEN
9716 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9717 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9720 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9721 OMPP21 = OMPP21+AVDIPP
9722 C OMPP21 = OMPP21+(CONE-PP21(K))
9723 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9724 DIPP21 = DIPP21+AVDIPP
9731 IF (PP12(K).EQ.CZERO) THEN
9735 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9736 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9739 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9740 OMPP12 = OMPP12+AVDIPP
9741 C OMPP12 = OMPP12+(CONE-PP12(K))
9742 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9743 DIPP12 = DIPP12+AVDIPP
9744 IF (PP22(K).EQ.CZERO) THEN
9748 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9749 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9752 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9753 OMPP22 = OMPP22+AVDIPP
9754 C OMPP22 = OMPP22+(CONE-PP22(K))
9755 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9756 DIPP22 = DIPP22+AVDIPP
9759 SPROM = ONE-EXP(SHI)
9760 SPROB = SPROB+FACM*SPROM
9761 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9762 STOTM = DBLE(OMPP11+OMPP22)
9763 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9764 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9765 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9766 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9767 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9768 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9769 STOTB = STOTB+FACM*STOTM
9770 SELAB = SELAB+FACM*SELAM
9771 SDELB = SDELB+FACM*SDELM
9773 SQEPB = SQEPB+FACM*SQEPM
9774 SDQEB = SDQEB+FACM*SDQEM
9776 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9777 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9778 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9783 STOTN = STOTN+FACB*STOTB
9784 SELAN = SELAN+FACB*SELAB
9785 SQEPN = SQEPN+FACB*SQEPB
9786 SQETN = SQETN+FACB*SQETB
9787 SQE2N = SQE2N+FACB*SQE2B
9788 SPRON = SPRON+FACB*SPROB
9789 SDELN = SDELN+FACB*SDELB
9790 SDQEN = SDQEN+FACB*SDQEB
9792 IF (IJPROJ.EQ.7) THEN
9793 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9795 IF (DIBETA.GT.ZERO) THEN
9796 BPROD(IB+1)= BPROD(IB+1)
9797 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9799 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9805 STOT = STOT +FACN*STOTN
9806 STOT2 = STOT2+FACN*STOTN**2
9807 SELA = SELA +FACN*SELAN
9808 SELA2 = SELA2+FACN*SELAN**2
9809 SQEP = SQEP +FACN*SQEPN
9810 SQEP2 = SQEP2+FACN*SQEPN**2
9811 SQET = SQET +FACN*SQETN
9812 SQET2 = SQET2+FACN*SQETN**2
9813 SQE2 = SQE2 +FACN*SQE2N
9814 SQE22 = SQE22+FACN*SQE2N**2
9815 SPRO = SPRO +FACN*SPRON
9816 SPRO2 = SPRO2+FACN*SPRON**2
9817 SDEL = SDEL +FACN*SDELN
9818 SDEL2 = SDEL2+FACN*SDELN**2
9819 SDQE = SDQE +FACN*SDQEN
9820 SDQE2 = SDQE2+FACN*SDQEN**2
9824 * final cross sections
9826 XSTOT(IE,IQ,NTARG) = STOT
9828 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9830 XSELA(IE,IQ,NTARG) = SELA
9831 * 3) quasi-el.: A+B-->A+X (excluding 2)
9832 XSQEP(IE,IQ,NTARG) = SQEP
9833 * 4) quasi-el.: A+B-->X+B (excluding 2)
9834 XSQET(IE,IQ,NTARG) = SQET
9835 * 5) quasi-el.: A+B-->X (excluding 2-4)
9836 XSQE2(IE,IQ,NTARG) = SQE2
9837 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9838 IF (SDEL.GT.ZERO) THEN
9839 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9841 XSPRO(IE,IQ,NTARG) = SPRO
9843 * 7) projectile diffraction (el. scatt. off target)
9844 XSDEL(IE,IQ,NTARG) = SDEL
9845 * 8) projectile diffraction (quasi-el. scatt. off target)
9846 XSDQE(IE,IQ,NTARG) = SDQE
9848 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9849 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9850 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9851 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9852 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9853 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9854 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9855 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9857 IF (IJPROJ.EQ.7) THEN
9858 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9859 & -XSQEP(IE,IQ,NTARG)
9861 BNORM = XSPRO(IE,IQ,NTARG)
9864 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9865 IF ((IE.EQ.1).AND.(IQ.EQ.1))
9866 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9869 * write profile function data into file
9870 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9871 WRITE(LDAT,'(5I10,1P,E15.5)')
9872 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9873 WRITE(LDAT,'(1P,6E12.5)')
9874 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9875 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9876 WRITE(LDAT,'(1P,6E12.5)')
9877 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9878 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9879 NLINES = INT(DBLE(NSITEB)/7.0D0)
9880 IF (NLINES.GT.0) THEN
9883 WRITE(LDAT,'(1P,7E11.4)')
9884 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9888 IF (ISTART.LE.NSITEB) THEN
9889 WRITE(LDAT,'(1P,7E11.4)')
9890 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9896 C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9901 *$ CREATE DT_GETBXS.FOR
9904 *===getbxs=============================================================*
9906 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9908 ************************************************************************
9909 * Biasing in impact parameter space. *
9910 * XSFRAC = 0 : BLO - minimum impact parameter (input) *
9911 * BHI - maximum impact parameter (input) *
9912 * XSFRAC - fraction of cross section corresponding *
9913 * to impact parameter range (BLO,BHI) *
9915 * XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
9916 * BHI - maximum impact parameter giving requested *
9917 * fraction of cross section in impact *
9918 * parameter range (0,BMAX) (output) *
9919 * This version dated 17.03.00 is written by S. Roesler *
9920 ************************************************************************
9922 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9924 PARAMETER ( LINP = 10 ,
9928 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9929 * Glauber formalism: parameters
9930 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9931 & BMAX(NCOMPX),BSTEP(NCOMPX),
9932 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9936 IF (XSFRAC.LE.0.0D0) THEN
9937 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9938 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9939 IF (ILO.GE.IHI) THEN
9943 IF (ILO.EQ.NSITEB-1) THEN
9944 FRCLO = BSITE(0,1,NTARG,NSITEB)
9946 FRCLO = BSITE(0,1,NTARG,ILO+1)
9947 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9948 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9950 IF (IHI.EQ.NSITEB-1) THEN
9951 FRCHI = BSITE(0,1,NTARG,NSITEB)
9953 FRCHI = BSITE(0,1,NTARG,IHI+1)
9954 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9955 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9957 XSFRAC = FRCHI-FRCLO
9962 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9963 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
9964 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9965 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9975 *$ CREATE DT_CONUCL.FOR
9978 *===conucl=============================================================*
9980 SUBROUTINE DT_CONUCL(X,N,R,MODE)
9982 ************************************************************************
9983 * Calculation of coordinates of nucleons within nuclei. *
9984 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
9985 * N / R number of nucleons / radius of nucleus (input) *
9986 * MODE = 0 coordinates not sorted *
9987 * = 1 coordinates sorted with increasing X(3,i) *
9988 * = 2 coordinates sorted with decreasing X(3,i) *
9989 * This version dated 26.10.95 is revised by S. Roesler *
9990 ************************************************************************
9992 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9994 PARAMETER ( LINP = 10 ,
9998 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9999 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10001 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10003 PARAMETER (NSRT=10)
10004 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10005 DIMENSION X(3,N),XTMP(3,260)
10007 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10009 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10012 IF (MODE.EQ.2) THEN
10018 DO 2 J=1,ICSRT(ISRT)
10020 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10021 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10022 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10024 IF (ICSRT(ISRT).GT.1) THEN
10027 CALL DT_SORT(X,N,I0,I1,MODE)
10030 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10036 CALL DT_SORT(X,N,1,N,MODE)
10048 *$ CREATE DT_COORDI.FOR
10051 *===coordi=============================================================*
10053 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10055 ************************************************************************
10056 * Calculation of coordinates of nucleons within nuclei. *
10057 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
10058 * N / R number of nucleons / radius of nucleus (input) *
10059 * Based on the original version by Shmakov et al. *
10060 * This version dated 26.10.95 is revised by S. Roesler *
10061 ************************************************************************
10063 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10065 PARAMETER ( LINP = 10 ,
10069 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10070 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10072 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10076 PARAMETER (NSRT=10)
10077 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10078 DIMENSION X(3,260),WD(4),RD(3)
10080 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10081 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10082 DATA RD /2.09D0, 0.935D0, 0.697D0/
10092 ELSEIF (N.EQ.2) THEN
10093 EPS = DT_RNDM(RD(1))
10095 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10099 CALL DT_RANNOR(X1,X2)
10103 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10106 CALL DT_RANNOR(X3,X4)
10108 CALL DT_RANNOR(X1,X2)
10111 IF (LSTART) GOTO 80
10113 CALL DT_RANNOR(X3,X4)
10118 LSTART = .NOT.LSTART
10119 X1SUM = X1SUM+X(1,I)
10120 X2SUM = X2SUM+X(2,I)
10121 X3SUM = X3SUM+X(3,I)
10123 X1SUM = X1SUM/DBLE(N)
10124 X2SUM = X2SUM/DBLE(N)
10125 X3SUM = X3SUM/DBLE(N)
10127 X(1,I) = X(1,I)-X1SUM
10128 X(2,I) = X(2,I)-X2SUM
10129 X(3,I) = X(3,I)-X3SUM
10133 * maximum nuclear radius for coordinate sampling
10134 RMAX = R+4.605D0*PDIF
10136 * initialize pre-sorting
10140 DR = TWO*RMAX/DBLE(NSRT)
10142 * sample coordinates for N nucleons
10145 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10146 F = DT_DENSIT(N,RAD,R)
10147 IF (DT_RNDM(RAD).GT.F) GOTO 120
10148 * theta, phi uniformly distributed
10149 CT = ONE-TWO*DT_RNDM(F)
10150 ST = SQRT((ONE-CT)*(ONE+CT))
10151 CALL DT_DSFECF(SFE,CFE)
10152 X(1,I) = RAD*ST*CFE
10153 X(2,I) = RAD*ST*SFE
10155 * ensure that distance between two nucleons is greater than R2MIN
10156 IF (I.LT.2) GOTO 122
10159 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10160 & (X(3,I)-X(3,I2))**2
10161 IF (DIST2.LE.R2MIN) GOTO 120
10164 * save index according to z-bin
10165 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10166 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10167 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10168 X1SUM = X1SUM+X(1,I)
10169 X2SUM = X2SUM+X(2,I)
10170 X3SUM = X3SUM+X(3,I)
10172 X1SUM = X1SUM/DBLE(N)
10173 X2SUM = X2SUM/DBLE(N)
10174 X3SUM = X3SUM/DBLE(N)
10176 X(1,I) = X(1,I)-X1SUM
10177 X(2,I) = X(2,I)-X2SUM
10178 X(3,I) = X(3,I)-X3SUM
10186 *$ CREATE DT_DENSIT.FOR
10189 *===densit=============================================================*
10191 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10193 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10196 PARAMETER ( LINP = 10 ,
10199 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10200 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10203 DIMENSION R0(18),FNORM(18)
10204 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10205 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10206 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10207 & 2.72D0, 2.66D0, 2.79D0/
10208 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10209 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10210 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10211 & .1214D+01,.1265D+01,.1318D+01/
10212 DATA PDIF /0.545D0/
10218 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10219 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10220 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10221 & *EXP(-(R/R1)**2)/FNORM(NA)
10223 ELSEIF (NA.GT.18) THEN
10224 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10230 *$ CREATE DT_RNCLUS.FOR
10233 *===rnclus=============================================================*
10235 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10237 ************************************************************************
10238 * Nuclear radius for nucleus with mass number N. *
10239 * This version dated 26.9.00 is written by S. Roesler *
10240 ************************************************************************
10242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10245 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10248 PARAMETER (RNUCLE = 1.12D0)
10250 * nuclear radii for selected nuclei
10251 DIMENSION RADNUC(18)
10252 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10253 & 2.58D0,2.71D0,2.66D0,2.71D0/
10256 IF (RADNUC(N).GT.0.0D0) THEN
10257 DT_RNCLUS = RADNUC(N)
10259 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10262 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10268 *$ CREATE DT_DENTST.FOR
10271 *===dentst=============================================================*
10273 C PROGRAM DT_DENTST
10274 SUBROUTINE DT_DENTST
10276 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10279 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10280 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10285 DR = (RMAX-RMIN)/DBLE(NBINS)
10289 R = RMIN+DBLE(IR-1)*DR
10290 F = DT_DENSIT(IA,R,R)
10291 IF (F.GT.FMAX) FMAX = F
10292 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10294 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10302 *$ CREATE DT_SHMAKI.FOR
10305 *===shmaki=============================================================*
10307 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10309 ************************************************************************
10310 * Initialisation of Glauber formalism. This subroutine has to be *
10311 * called once (in case of target emulsions as often as many different *
10312 * target nuclei are considered) before events are sampled. *
10313 * NA / NCA mass number/charge of projectile nucleus *
10314 * NB / NCB mass number/charge of target nucleus *
10315 * IJP identity of projectile (hadrons/leptons/photons) *
10316 * PPN projectile momentum (for projectile nuclei: *
10317 * momentum per nucleon) in target rest system *
10318 * MODE = 0 Glauber formalism invoked *
10319 * = 1 fitted results are loaded from data-file *
10320 * = 99 NTARG is forced to be 1 *
10321 * (used in connection with GLAUBERI-card only) *
10322 * This version dated 22.03.96 is based on the original SHMAKI-routine *
10323 * and revised by S. Roesler. *
10324 ************************************************************************
10326 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10328 PARAMETER ( LINP = 10 ,
10331 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10334 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10335 * Glauber formalism: parameters
10336 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10337 & BMAX(NCOMPX),BSTEP(NCOMPX),
10338 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10340 * Lorentz-parameters of the current interaction
10341 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10342 & UMO,PPCM,EPROJ,PPROJ
10343 * properties of photon/lepton projectiles
10344 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10345 * kinematical cuts for lepton-nucleus interactions
10346 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10347 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10348 * Glauber formalism: cross sections
10349 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10350 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10351 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10352 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10353 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10354 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10355 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10356 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10357 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10358 & BSLOPE,NEBINI,NQBINI
10359 * cuts for variable energy runs
10360 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10361 * nucleon-nucleon event-generator
10364 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10365 * Glauber formalism: flags and parameters for statistics
10368 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10370 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10376 IF (MODE.EQ.99) NTARG = 1
10378 IF (MODE.EQ.-1) NIDX = NTARG
10380 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10381 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10382 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10383 & ' initialization',/,12X,'--------------------------',
10384 & '-------------------------',/)
10386 IF (MODE.EQ.2) THEN
10387 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10388 CALL DT_SHFAST(MODE,PPN,IBACK)
10389 STOP ' Glauber pre-initialization done'
10391 IF (MODE.EQ.1) THEN
10392 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10395 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10396 IF (IBACK.EQ.1) THEN
10397 * lepton-nucleus (variable energy runs)
10398 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10399 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10400 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10401 & WRITE(LOUT,1002) NB,NCB
10402 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10403 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10404 & 'E_cm (GeV) Q^2 (GeV^2)',
10405 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10406 & '--------------------------------',
10407 & '------------------------------')
10408 AECMLO = LOG10(MIN(UMO,ECMLI))
10409 AECMHI = LOG10(MIN(UMO,ECMHI))
10411 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10412 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10414 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10415 IF (Q2HI.GT.0.1D0) THEN
10416 IF (Q2LI.LT.0.01D0) THEN
10417 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10418 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10420 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10427 AQ2LO = LOG10(Q2LI)
10428 AQ2HI = LOG10(Q2HI)
10429 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10430 DO 2 J=IBIN,IQSTEP+IBIN
10431 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10432 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10433 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10434 & WRITE(LOUT,1003) ECMNN(I),
10435 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10438 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10439 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10441 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10443 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10447 * hadron/photon/nucleus-nucleus
10448 IF ((ABS(VAREHI).GT.ZERO).AND.
10449 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10450 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10451 WRITE(LOUT,1004) NA,NB,NCB
10452 1004 FORMAT(1X,'variable energy run: projectile-id:',
10453 & I3,' target A/Z: ',I3,' /',I3,/)
10455 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10456 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10457 & ' -------------------------------------',
10458 & '--------------------------------------')
10460 AECMLO = LOG10(VARCLO)
10461 AECMHI = LOG10(VARCHI)
10463 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10464 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10466 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10471 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10472 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10473 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10474 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10476 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10477 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10481 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10487 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10488 & (IOGLB.NE.100)) THEN
10489 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10490 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10491 1001 FORMAT(38X,'projectile',
10492 & ' target',/,1X,'Mass number / charge',
10493 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10494 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10495 & 'Parameters of elastic scattering amplitude:',/,5X,
10496 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10497 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10498 & 'statistics at each b-step',4X,I5,/,/,1X,
10499 & 'Prod. cross section ',5X,F10.4,' mb',/)
10505 *$ CREATE DT_PROFBI.FOR
10508 *===profbi=============================================================*
10510 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10512 ************************************************************************
10513 * Integral over profile function (to be used for impact-parameter *
10514 * sampling during event generation). *
10515 * Fitted results are used. *
10516 * NA / NB mass numbers of proj./target nuclei *
10517 * PPN projectile momentum (for projectile nuclei: *
10518 * momentum per nucleon) in target rest system *
10519 * NTARG index of target material (i.e. kind of nucleus) *
10520 * This version dated 31.05.95 is revised by S. Roesler *
10521 ************************************************************************
10523 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10525 PARAMETER ( LINP = 10 ,
10530 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10535 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10536 * Glauber formalism: parameters
10537 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10538 & BMAX(NCOMPX),BSTEP(NCOMPX),
10539 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10541 * Glauber formalism: cross sections
10542 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10543 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10544 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10545 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10546 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10547 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10548 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10549 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10550 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10551 & BSLOPE,NEBINI,NQBINI
10553 PARAMETER (NGLMAX=8000)
10554 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10555 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10557 DATA LSTART /.TRUE./
10560 * read fit-parameters from file
10561 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10564 READ(47,'(A80)') CNAME
10565 IF (CNAME.EQ.'STOP') GOTO 2
10567 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10568 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10569 & GLAFIT(4,I),GLAFIT(5,I)
10570 IF (I+1.GT.NGLMAX) THEN
10572 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
10573 & 'program stopped')
10590 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10591 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10594 IF (J.EQ.NGLPAR) IPOINT = J+1-K
10595 IF ((NNA.GT.NGLIP(IPOINT)).OR.
10596 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10597 IF (IPOINT.EQ.1) IPOINT = 0
10598 NATMP = NGLIP(IPOINT+1)
10599 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10605 C IF (J.EQ.NGLPAR) THEN
10609 DO 5 J1=J1BEG,J1END
10610 IF (NGLIP(J1).EQ.NATMP) THEN
10611 IF (PPN.LT.GLAPPN(J1)) THEN
10620 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10629 IF (IDXGLA.EQ.0) THEN
10630 WRITE(LOUT,1001) NNA,NNB,PPN
10631 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
10632 & 2I4,F6.0,') not found ')
10636 * no interpolation yet available
10637 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10639 BSITE(1,1,NTARG,1) = ZERO
10642 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10643 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10644 & GLAFIT(5,IDXGLA)*XX**4
10645 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10646 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10647 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10653 *$ CREATE DT_GLAUBE.FOR
10656 *===glaube=============================================================*
10658 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10660 ************************************************************************
10661 * Calculation of configuartion of interacting nucleons for one event. *
10662 * NB / NB mass numbers of proj./target nuclei (input) *
10663 * B impact parameter (output) *
10664 * INTT total number of wounded nucleons " *
10665 * INTA / INTB number of wounded nucleons in proj. / target " *
10666 * JS / JT(i) number of collisions proj. / target nucleon i is *
10667 * involved (output) *
10668 * NIDX index of projectile/target material (input) *
10669 * = -2 call within FLUKA transport calculation *
10670 * This is an update of the original routine SHMAKO by J.Ranft/HJM *
10671 * This version dated 22.03.96 is revised by S. Roesler *
10673 * Last change 27.12.2006 by S. Roesler. *
10674 ************************************************************************
10676 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10678 PARAMETER ( LINP = 10 ,
10681 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10682 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10684 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10685 PARAMETER ( MAXNCL = 260,
10687 & MAXSQU = 20*MAXVQU,
10688 & MAXINT = MAXVQU+MAXSQU)
10689 * Glauber formalism: parameters
10690 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10691 & BMAX(NCOMPX),BSTEP(NCOMPX),
10692 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10694 * Glauber formalism: cross sections
10695 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10696 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10697 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10698 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10699 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10700 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10701 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10702 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10703 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10704 & BSLOPE,NEBINI,NQBINI
10705 * Lorentz-parameters of the current interaction
10706 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10707 & UMO,PPCM,EPROJ,PPROJ
10708 * properties of photon/lepton projectiles
10709 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10710 * Glauber formalism: collision properties
10711 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10712 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10713 * Glauber formalism: flags and parameters for statistics
10716 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10718 DIMENSION JS(MAXNCL),JT(MAXNCL)
10722 * get actual energy from /DTLTRA/
10726 * new patch for pre-initialized variable projectile/target/energy runs,
10727 * bypassed for use within FLUKA (Nidx=-2)
10728 IF (IOGLB.EQ.100) THEN
10729 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10731 * variable energy run, interpolate profile function
10736 IF (NEBINI.GT.1) THEN
10737 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10741 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10743 IF (ECMNOW.LT.ECMNN(I)) THEN
10746 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10756 IF (NQBINI.GT.1) THEN
10757 IF (Q2.GE.Q2G(NQBINI)) THEN
10761 ELSEIF (Q2.GT.Q2G(1)) THEN
10763 IF (Q2.LT.Q2G(I)) THEN
10766 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
10767 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10768 C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10777 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10778 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10779 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10780 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10781 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10785 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10786 IF (NIDX.LE.-1) THEN
10788 RTARG = RBSH(NTARG)
10790 RPROJ = RASH(NTARG)
10797 *$ CREATE DT_DIAGR.FOR
10800 *===diagr==============================================================*
10802 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10805 ************************************************************************
10806 * Based on the original version by Shmakov et al. *
10807 * This version dated 21.04.95 is revised by S. Roesler *
10808 ************************************************************************
10810 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10812 PARAMETER ( LINP = 10 ,
10815 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10816 PARAMETER (TWOPI = 6.283185307179586454D+00,
10818 & GEV2MB = 0.38938D0,
10819 & GEV2FM = 0.1972D0,
10820 & ALPHEM = ONE/137.0D0,
10828 PARAMETER ( MAXNCL = 260,
10830 & MAXSQU = 20*MAXVQU,
10831 & MAXINT = MAXVQU+MAXSQU)
10832 * particle properties (BAMJET index convention)
10834 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10835 & IICH(210),IIBAR(210),K1(210),K2(210)
10836 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10837 * emulsion treatment
10838 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10840 * Glauber formalism: parameters
10841 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10842 & BMAX(NCOMPX),BSTEP(NCOMPX),
10843 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10845 * Glauber formalism: cross sections
10846 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10847 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10848 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10849 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10850 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10851 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10852 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10853 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10854 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10855 & BSLOPE,NEBINI,NQBINI
10856 * VDM parameter for photon-nucleus interactions
10857 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10858 * nucleon-nucleon event-generator
10861 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10863 C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10865 C obsolete cut-off information
10866 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10867 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10869 * coordinates of nucleons
10870 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10871 * interface between Glauber formalism and DPM
10872 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10873 & INTER1(MAXINT),INTER2(MAXINT)
10874 * statistics: Glauber-formalism
10875 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10876 * n-n cross section fluctuations
10877 PARAMETER (NBINS = 1000)
10878 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10880 DIMENSION JS(MAXNCL),JT(MAXNCL),
10881 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10882 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10883 DIMENSION NWA(0:210),NWB(0:210)
10886 DATA LFIRST /.TRUE./
10888 DATA NTARGO,ICNT /0,0/
10894 IF (NCOMPO.EQ.0) THEN
10904 IF (NTARG.EQ.-1) THEN
10905 IF (NCOMPO.EQ.0) THEN
10906 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10907 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10908 & NCALL,NWAMAX,NWBMAX
10909 DO 18 I=1,MAX(NWAMAX,NWBMAX)
10910 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10911 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10912 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10922 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10924 X = SQ2/(S+SQ2-AMP2)
10925 XNU = (S+SQ2-AMP2)/(TWO*AMP)
10926 * photon projectiles: recalculate photon-nucleon amplitude
10927 IF (IJPROJ.EQ.7) THEN
10929 * VDM assumption: mass of V-meson
10930 AMV2 = DT_SAM2(SQ2,ECMNOW)
10932 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10933 * check for pointlike interaction
10934 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10936 C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10937 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10940 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10941 & +0.25D0*LOG(S/(AMV2+SQ2)))
10943 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10944 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10945 IF (MCGENE.EQ.2) THEN
10947 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10950 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10952 IF (ECMNOW.LE.3.0D0) THEN
10954 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10955 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10956 ELSEIF (ECMNOW.GT.50.0D0) THEN
10959 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10960 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10961 IF (MCGENE.EQ.2) THEN
10963 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10965 SIGSH = SIGSH/10.0D0
10967 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10969 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10970 SIGSH = SIGSH/10.0D0
10973 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10975 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10976 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10977 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10979 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10980 SIGSH = SIGSH/10.0D0
10982 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10984 RCA = GAM*SIGSH/TWOPI
10986 CA = DCMPLX(RCA,FCA)
10987 CI = DCMPLX(ONE,ZERO)
10991 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11004 IF (IJPROJ.EQ.7) THEN
11014 * nucleon configuration
11015 C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11016 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11017 C CALL DT_CONUCL(PKOO,NA,RASH,2)
11018 C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11019 IF (NIDX.LE.-1) THEN
11020 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11021 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11023 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11024 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11030 * LEPTO: pick out one struck nucleon
11031 IF (MCGENE.EQ.3) THEN
11034 IDX = INT(DT_RNDM(X)*NB)+1
11041 * cross section fluctuations
11043 IF (IFLUCT.EQ.1) THEN
11044 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11045 AFLUC = FLUIXX(IFLUK)
11050 * photon-projectile: check for supression by coherence length
11051 IF (IJPROJ.EQ.7) THEN
11052 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11057 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11058 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11059 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11060 IF (XY.LE.15.0D0) THEN
11061 C = CI-CA*AFLUC*EXP(-XY)
11065 IF (DT_RNDM(XY).GE.P) THEN
11067 IF (IJPROJ.EQ.7) THEN
11068 JNT0(KINT) = JNT0(KINT)+1
11069 IF (JNT0(KINT).GT.MAXNCL) THEN
11070 WRITE(LOUT,1001) MAXNCL
11072 & 'DIAGR: no. of requested interactions',
11073 & ' exceeds array dimensions ',I4)
11076 JS0(KINT) = JS0(KINT)+1
11077 JT0(KINT,INB) = JT0(KINT,INB)+1
11078 JI1(KINT,JNT0(KINT)) = INA
11079 JI2(KINT,JNT0(KINT)) = INB
11081 IF (JNT.GT.MAXINT) THEN
11082 WRITE(LOUT,1000) JNT, MAXINT
11084 & 'DIAGR: no. of requested interactions ('
11085 & ,I4,') exceeds array dimensions (',I4,')')
11088 JS(INA) = JS(INA)+1
11089 JT(INB) = JT(INB)+1
11099 IF (NTRY.LT.500) THEN
11102 C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11108 IF (IJPROJ.EQ.7) THEN
11109 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11111 IF (JNT0(K).EQ.0) THEN
11113 IF (K.GT.KINT) K = 1
11116 * supress Glauber-cascade by direct photon processes
11117 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11118 IF (IPNT.GT.0) THEN
11122 JT(INB) = JT0(K,INB)
11123 IF (JT(INB).GT.0) GOTO 12
11133 JT(INB) = JT0(K,INB)
11136 INTER1(I) = JI1(K,I)
11137 INTER2(I) = JI2(K,I)
11146 IF (JS(I).NE.0) INTA=INTA+1
11149 IF (JT(I).NE.0) INTB=INTB+1
11158 IF (NCOMPO.EQ.0) THEN
11160 NWA(INTA) = NWA(INTA)+1
11161 NWB(INTB) = NWB(INTB)+1
11167 *$ CREATE DT_MODB.FOR
11170 *===modb===============================================================*
11172 SUBROUTINE DT_MODB(B,NIDX)
11174 ************************************************************************
11175 * Sampling of impact parameter of collision. *
11176 * B impact parameter (output) *
11177 * NIDX index of projectile/target material (input)*
11178 * Based on the original version by Shmakov et al. *
11179 * This version dated 21.04.95 is revised by S. Roesler *
11181 * Last change 27.12.2006 by S. Roesler. *
11182 ************************************************************************
11184 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11186 PARAMETER ( LINP = 10 ,
11189 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11191 LOGICAL LEFT,LFIRST
11193 * central particle production, impact parameter biasing
11194 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11195 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11196 * Glauber formalism: parameters
11197 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11198 & BMAX(NCOMPX),BSTEP(NCOMPX),
11199 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11201 * Glauber formalism: cross sections
11202 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11203 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11204 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11205 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11206 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11207 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11208 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11209 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11210 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11211 & BSLOPE,NEBINI,NQBINI
11213 DATA LFIRST /.TRUE./
11216 IF (NIDX.LE.-1) THEN
11224 IF (ICENTR.EQ.2) THEN
11226 BB = DT_RNDM(B)*(0.3D0*RA)**2
11228 ELSEIF(RA.LT.RB)THEN
11229 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11231 ELSEIF(RA.GT.RB)THEN
11232 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11242 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11243 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11250 IF (I2-I0-2) 40,50,60
11253 IF (I1.GT.NSITEB) I1 = I0-1
11261 X0 = DBLE(I0-1)*BSTEP(NTARG)
11262 X1 = DBLE(I1-1)*BSTEP(NTARG)
11263 X2 = DBLE(I2-1)*BSTEP(NTARG)
11264 Y0 = BSITE(0,1,NTARG,I0)
11265 Y1 = BSITE(0,1,NTARG,I1)
11266 Y2 = BSITE(0,1,NTARG,I2)
11268 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11269 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11270 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11271 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11272 B = B+0.5D0*BSTEP(NTARG)
11273 IF (B.LT.ZERO) B = X1
11274 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11275 IF (ICENTR.LT.0) THEN
11278 IF (ICENTR.LE.-100) THEN
11283 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11284 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11285 & BIMIN,BIMAX,XSFRAC*100.0D0,
11286 & XSFRAC*XSPRO(1,1,NTARG)
11287 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11288 & /,15X,'---------------------------'/,/,4X,
11289 & 'average radii of proj / targ :',F10.3,' fm /',
11290 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11291 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11292 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11293 & ' cross section :',F10.3,' %',/,5X,
11294 & 'corresponding cross section :',F10.3,' mb',/)
11296 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11299 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11307 *$ CREATE DT_SHFAST.FOR
11310 *===shfast=============================================================*
11312 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11314 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11316 PARAMETER ( LINP = 10 ,
11319 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11320 & ONE=1.0D0,TWO=2.0D0)
11322 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11323 * Glauber formalism: parameters
11324 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11325 & BMAX(NCOMPX),BSTEP(NCOMPX),
11326 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11328 * properties of interacting particles
11329 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11330 * Glauber formalism: cross sections
11331 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11332 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11333 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11334 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11335 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11336 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11337 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11338 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11339 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11340 & BSLOPE,NEBINI,NQBINI
11344 IF (MODE.EQ.2) THEN
11345 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11346 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11347 1000 FORMAT(1X,8I5,E15.5)
11348 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11349 1001 FORMAT(1X,4E15.5)
11350 WRITE(47,1002) SIGSH,ROSH,GSH
11351 1002 FORMAT(1X,3E15.5)
11353 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11355 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11356 1003 FORMAT(1X,2I10,3E15.5)
11359 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11360 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11361 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11362 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11363 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11364 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11365 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11366 READ(47,1002) SIGSH,ROSH,GSH
11368 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11370 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11380 *$ CREATE DT_POILIK.FOR
11383 *===poilik=============================================================*
11385 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11387 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11390 PARAMETER ( LINP = 10 ,
11393 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11397 C CHARACTER*8 MDLNA
11398 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11399 C PARAMETER (IEETAB=10)
11400 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11402 C model switches and parameters
11404 INTEGER ISWMDL,IPAMDL
11405 DOUBLE PRECISION PARMDL
11406 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11407 C energy-interpolation table
11409 PARAMETER ( IEETA2 = 20 )
11411 DOUBLE PRECISION SIGTAB,SIGECM
11412 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11414 * VDM parameter for photon-nucleus interactions
11415 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11417 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11418 * Glauber formalism: cross sections
11419 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11420 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11421 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11422 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11423 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11424 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11425 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11426 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11427 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11428 & BSLOPE,NEBINI,NQBINI
11431 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11433 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11435 * load cross sections from interpolation table
11437 IF(ECM.LE.SIGECM(IP,1)) THEN
11440 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11442 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11448 WRITE(LOUT,'(/1X,A,2E12.3)')
11449 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11454 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11455 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11458 SIGANO = DT_SANO(ECM)
11460 * cross section dependence on photon virtuality
11463 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11464 & /(ONE+VIRT/PARMDL(30+I))**2
11466 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11476 C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11477 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11478 IF (ISHAD(1).EQ.1) THEN
11479 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11483 SIGANO = FSUP1*FSUP2*SIGANO
11484 SIGTOT = SIGTOT-SIGDIR-SIGANO
11485 SIGDIR = SIGDIR/(FSUP1*FSUP2)
11486 SIGANO = SIGANO/(FSUP1*FSUP2)
11487 SIGTOT = SIGTOT+SIGDIR+SIGANO
11489 RR = DT_RNDM(SIGTOT)
11490 IF (RR.LT.SIGDIR/SIGTOT) THEN
11492 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11493 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11498 RPNT = (SIGDIR+SIGANO)/SIGTOT
11499 C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11500 C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11501 C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11502 C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11503 IF (MODE.EQ.1) RETURN
11509 IF (ECM.GE.ECMNN(NEBINI)) THEN
11513 ELSEIF (ECM.GT.ECMNN(1)) THEN
11515 IF (ECM.LT.ECMNN(I)) THEN
11518 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11527 IF (NQBINI.GT.1) THEN
11528 IF (VIRT.GE.Q2G(NQBINI)) THEN
11532 ELSEIF (VIRT.GT.Q2G(1)) THEN
11534 IF (VIRT.LT.Q2G(I)) THEN
11537 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
11538 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11545 SGA = XSPRO(K1,J1,NTARG)+
11546 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11547 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11548 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11549 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11550 SDI = DBLE(NB)*SIGDIR
11551 SAN = DBLE(NB)*SIGANO
11554 IF (RR.LT.SDI/SGA) THEN
11556 ELSEIF ((RR.GE.SDI/SGA).AND.
11557 & (RR.LT.SPL/SGA)) THEN
11563 C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11569 *$ CREATE DT_GLBINI.FOR
11572 *===glbini=============================================================*
11574 SUBROUTINE DT_GLBINI(WHAT)
11576 ************************************************************************
11577 * Pre-initialization of profile function *
11578 * This version dated 28.11.00 is written by S. Roesler. *
11580 * Last change 27.12.2006 by S. Roesler. *
11581 ************************************************************************
11583 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11586 PARAMETER ( LINP = 10 ,
11589 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11593 * particle properties (BAMJET index convention)
11595 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11596 & IICH(210),IIBAR(210),K1(210),K2(210)
11597 * properties of interacting particles
11598 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11599 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11600 * emulsion treatment
11601 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11603 * Glauber formalism: flags and parameters for statistics
11606 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11607 * number of data sets other than protons and nuclei
11608 * at the moment = 2 (pions and kaons)
11609 PARAMETER (MAXOFF=2)
11610 DIMENSION IJPINI(5),IOFFST(25)
11611 DATA IJPINI / 13, 15, 0, 0, 0/
11612 * Glauber data-set to be used for hadron projectiles
11613 * (0=proton, 1=pion, 2=kaon)
11614 DATA (IOFFST(K),K=1,25) /
11615 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11617 * Acceptance interval for target nucleus mass
11618 PARAMETER (KBACC = 6)
11619 * flags for input different options
11620 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11621 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11622 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11624 PARAMETER (MAXMSS = 100)
11625 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11628 DATA JPEACH,JPSTEP / 18, 5 /
11630 * temporary patch until fix has been implemented in phojet:
11631 * maximum energy for pion projectile
11632 DATA ECMXPI / 100000.0D0 /
11634 *--------------------------------------------------------------------------
11635 * general initializations
11637 * steps in projectile mass number for initialization
11638 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11639 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11641 * energy range and binning
11644 IF (ELO.GT.EHI) ELO = EHI
11645 NEBIN = MAX(INT(WHAT(3)),1)
11646 IF (ELO.EQ.EHI) NEBIN = 0
11647 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11651 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11652 & +2.0D0*AAM(IJTARG)*EHI)
11655 * default arguments for Glauber-routine
11659 * initialize nuclear parameters, etc.
11663 * open Glauber-data output file
11664 IDX = INDEX(CGLB,' ')
11666 IF (IDX.GT.1) K = IDX-1
11667 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11669 *--------------------------------------------------------------------------
11670 * Glauber-initialization for proton and nuclei projectiles
11672 * initialize phojet for proton-proton interactions
11675 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11678 * record projectile masses
11680 NPROJ = MIN(IP,JPEACH)
11681 DO 10 KPROJ=1,NPROJ
11683 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11684 IASAV(NASAV) = KPROJ
11686 IF (IP.GT.JPEACH) THEN
11687 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11688 IF (NPROJ.EQ.0) THEN
11690 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11693 DO 11 IPROJ=1,NPROJ
11694 KPROJ = JPEACH+IPROJ*JPSTEP
11696 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11697 IASAV(NASAV) = KPROJ
11699 IF (KPROJ.LT.IP) THEN
11701 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11707 * record target masses
11710 IF (NCOMPO.GT.0) NTARG = NCOMPO
11711 DO 12 ITARG=1,NTARG
11713 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11714 IF (NCOMPO.GT.0) THEN
11715 IBSAV(NBSAV) = IEMUMA(ITARG)
11722 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11723 1000 FORMAT(I4,A,1P,2E13.5)
11724 NLINES = DBLE(NASAV)/18.0D0
11725 IF (NLINES.GT.0) THEN
11728 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11730 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11735 IF (I0.LE.NASAV) THEN
11737 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11739 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11742 NLINES = DBLE(NBSAV)/18.0D0
11743 IF (NLINES.GT.0) THEN
11746 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11748 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11753 IF (I0.LE.NBSAV) THEN
11755 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11757 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11761 * calculate Glauber-data for each energy and mass combination
11763 * loop over energy bins
11766 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11768 E = ELO+DBLE(IE-1)*DEBIN
11771 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11776 E = MAX(AAM(IJPROJ)+0.1D0,E)
11777 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11780 * loop over projectile and target masses
11783 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11784 & XI,Q2I,ECM,1,1,-1)
11790 *--------------------------------------------------------------------------
11791 * Glauber-initialization for pion, kaon, ... projectiles
11795 * initialize phojet for this interaction
11798 IJPROJ = IJPINI(IJ)
11802 * temporary patch until fix has been implemented in phojet:
11803 IF (ECMINI.GT.ECMXPI) THEN
11804 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11806 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11810 * calculate Glauber-data for each energy and mass combination
11812 * loop over energy bins
11814 E = ELO+DBLE(IE-1)*DEBIN
11817 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11822 E = MAX(AAM(IJPROJ)+TINY14,E)
11823 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11826 * loop over projectile and target masses
11828 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11835 *--------------------------------------------------------------------------
11836 * close output unit(s), etc.
11843 *$ CREATE DT_GLBSET.FOR
11846 *===glbset=============================================================*
11848 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11849 ************************************************************************
11850 * Interpolation of pre-initialized profile functions *
11851 * This version dated 28.11.00 is written by S. Roesler. *
11852 ************************************************************************
11854 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11857 PARAMETER ( LINP = 10 ,
11860 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11862 LOGICAL LCMS,LREAD,LFRST1,LFRST2
11864 * particle properties (BAMJET index convention)
11866 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11867 & IICH(210),IIBAR(210),K1(210),K2(210)
11868 * Glauber formalism: flags and parameters for statistics
11871 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11872 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11873 * Glauber formalism: parameters
11874 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11875 & BMAX(NCOMPX),BSTEP(NCOMPX),
11876 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11878 * Glauber formalism: cross sections
11879 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11880 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11881 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11882 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11883 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11884 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11885 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11886 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11887 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11888 & BSLOPE,NEBINI,NQBINI
11889 * number of data sets other than protons and nuclei
11890 * at the moment = 2 (pions and kaons)
11891 PARAMETER (MAXOFF=2)
11892 DIMENSION IJPINI(5),IOFFST(25)
11893 DATA IJPINI / 13, 15, 0, 0, 0/
11894 * Glauber data-set to be used for hadron projectiles
11895 * (0=proton, 1=pion, 2=kaon)
11896 DATA (IOFFST(K),K=1,25) /
11897 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11899 * Acceptance interval for target nucleus mass
11900 PARAMETER (KBACC = 6)
11901 * emulsion treatment
11902 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11905 PARAMETER (MAXSET=5000,
11907 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11908 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11909 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11912 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11914 * read data from file
11916 IF (MODE.EQ.0) THEN
11939 IDX = INDEX(CGLB,' ')
11941 IF (IDX.GT.1) K = IDX-1
11942 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11943 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11944 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
11947 * read binning information
11948 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11949 * return lower energy threshold to Fluka-interface
11952 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11954 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11956 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11958 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
11959 & 'No. of bins:',I5,/)
11960 ELO = LOG10(ABS(ELO))
11961 EHI = LOG10(ABS(EHI))
11962 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11963 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11964 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11965 IF (NABIN.LT.18) THEN
11966 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11968 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11970 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11971 IF (NABIN.GT.18) THEN
11972 NLINES = DBLE(NABIN-18)/18.0D0
11973 IF (NLINES.GT.0) THEN
11976 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11977 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11980 I0 = 18*(NLINES+1)+1
11981 IF (I0.LE.NABIN) THEN
11982 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11983 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11986 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11987 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11988 IF (NBBIN.LT.18) THEN
11989 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
11991 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
11993 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
11994 IF (NBBIN.GT.18) THEN
11995 NLINES = DBLE(NBBIN-18)/18.0D0
11996 IF (NLINES.GT.0) THEN
11999 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12000 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12003 I0 = 18*(NLINES+1)+1
12004 IF (I0.LE.NBBIN) THEN
12005 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12006 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12009 * number of data sets to follow in the Glauber data file
12010 * this variable is used for checks of consistency of projectile
12011 * and target mass configurations given in header of Glauber data
12012 * file and the data-sets which follow in this file
12013 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12015 * read profile function data
12021 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12022 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12023 1002 FORMAT(5I10,E15.5)
12024 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12026 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12030 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12031 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12032 NLINES = INT(DBLE(ISITEB)/7.0D0)
12033 IF (NLINES.GT.0) THEN
12035 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12040 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12044 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12045 WRITE(LOUT,'(/,1X,A)')
12046 & ' projectiles other than protons and nuclei: (particle index)'
12047 IF (NAIDX.GT.0) THEN
12048 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12050 WRITE(LOUT,'(6X,A)') 'none'
12057 IF (NCOMPO.EQ.0) THEN
12060 IEMUMA(NCOMPO) = IBBIN(J)
12061 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12062 EMUFRA(NCOMPO) = 1.0D0
12067 * calculate profile function for certain set of parameters
12071 c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12073 * check for type of projectile and set index-offset to entry in
12074 * Glauber data array correspondingly
12075 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12076 IF (IOFFST(IDPROJ).EQ.-1) THEN
12077 STOP ' GLBSET: no data for this projectile !'
12078 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12079 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12084 * get energy bin and interpolation factor
12086 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12093 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12100 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12105 IE0 = (E-ELO)/DEBIN+1
12107 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12109 * get target nucleus index
12113 NBDIFF = ABS(NB-IBBIN(I))
12114 IF (NB.EQ.IBBIN(I)) THEN
12117 ELSEIF (NBDIFF.LE.NBACC) THEN
12122 IF (KB.NE.0) GOTO 21
12123 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12127 * get projectile nucleus bin and interpolation factor
12131 IF (IDXOFF.GT.0) THEN
12136 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12138 IF (NA.EQ.IABIN(I)) THEN
12142 ELSEIF (NA.LT.IABIN(I)) THEN
12148 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12152 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12156 * interpolate profile functions for interactions ka0-kb and ka1-kb
12157 * for energy E separately
12158 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12159 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12160 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12161 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12163 BPRO0(I) = BPROFL(IDX0,I)
12164 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12165 BPRO1(I) = BPROFL(IDY0,I)
12166 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12168 RADB = DT_RNCLUS(NB)
12169 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12170 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12172 * interpolate cross sections for energy E and projectile mass
12174 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12175 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12176 XS(I) = XS0+FACNA*(XS1-XS0)
12177 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12178 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12179 XE(I) = XE0+FACNA*(XE1-XE0)
12182 * interpolate between ka0 and ka1
12183 RADA = DT_RNCLUS(NA)
12184 BMX = 2.0D0*(RADA+RADB)
12185 BSTP = BMX/DBLE(ISITEB-1)
12190 * calculate values of profile functions at B
12192 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12193 IDX1 = MIN(IDX0+1,ISITEB)
12194 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12195 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12197 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12198 IDX1 = MIN(IDX0+1,ISITEB)
12199 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12200 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12202 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12205 * fill common dtglam
12212 BSITE(0,1,1,I) = BPRO(I)
12215 * fill common dtglxs
12216 XSTOT(1,1,1) = XS(1)
12217 XSELA(1,1,1) = XS(2)
12218 XSQEP(1,1,1) = XS(3)
12219 XSQET(1,1,1) = XS(4)
12220 XSQE2(1,1,1) = XS(5)
12221 XSPRO(1,1,1) = XS(6)
12222 XETOT(1,1,1) = XE(1)
12223 XEELA(1,1,1) = XE(2)
12224 XEQEP(1,1,1) = XE(3)
12225 XEQET(1,1,1) = XE(4)
12226 XEQE2(1,1,1) = XE(5)
12227 XEPRO(1,1,1) = XE(6)
12234 *$ CREATE DT_XKSAMP.FOR
12237 *===xksamp=============================================================*
12239 SUBROUTINE DT_XKSAMP(NN,ECM)
12241 ************************************************************************
12242 * Sampling of parton x-values and chain system for one interaction. *
12243 * processed by S. Roesler, 9.8.95 *
12244 ************************************************************************
12246 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12248 PARAMETER ( LINP = 10 ,
12251 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12255 * lower cuts for (valence-sea/sea-valence) chain masses
12256 * antiquark-quark (u/d-sea quark) (s-sea quark)
12257 & AMIU = 0.5D0, AMIS = 0.8D0,
12258 * quark-diquark (u/d-sea quark) (s-sea quark)
12259 & AMAU = 2.6D0, AMAS = 2.6D0,
12260 * maximum lower valence-x threshold
12262 * fraction of sea-diquarks sampled out of sea-partons
12264 C & FRCDIQ = 0.9D0,
12269 * maximum number of trials to generate x's for the required number
12270 * of sea quark pairs for a given hadron
12275 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12277 PARAMETER ( MAXNCL = 260,
12279 & MAXSQU = 20*MAXVQU,
12280 & MAXINT = MAXVQU+MAXSQU)
12282 PARAMETER (NMXHKK=200000)
12283 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12284 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12285 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12286 * particle properties (BAMJET index convention)
12288 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12289 & IICH(210),IIBAR(210),K1(210),K2(210)
12290 * interface between Glauber formalism and DPM
12291 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12292 & INTER1(MAXINT),INTER2(MAXINT)
12293 * properties of interacting particles
12294 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12295 * threshold values for x-sampling (DTUNUC 1.x)
12296 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12298 * x-values of partons (DTUNUC 1.x)
12299 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12300 & XTVQ(MAXVQU),XTVD(MAXVQU),
12301 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12302 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12303 * flavors of partons (DTUNUC 1.x)
12304 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12305 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12306 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12307 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12308 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12309 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12310 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12311 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12312 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12313 & IXPV,IXPS,IXTV,IXTS,
12314 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12315 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12316 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12317 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12318 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12319 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12320 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12321 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12322 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12323 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12324 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12325 * auxiliary common for chain system storage (DTUNUC 1.x)
12326 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12327 * flags for input different options
12328 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12329 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12330 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12331 * various options for treatment of partons (DTUNUC 1.x)
12332 * (chain recombination, Cronin,..)
12333 LOGICAL LCO2CR,LINTPT
12334 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12337 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12340 * (1) initializations
12341 *-----------------------------------------------------------------------
12344 IF (ECM.LT.4.5D0) THEN
12347 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12348 C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12349 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12358 IF (I.LE.MAXVQU) THEN
12364 * lower thresholds for x-selection
12365 * sea-quarks (default: CSEA=0.2)
12366 IF (ECM.LT.10.0D0) THEN
12368 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12369 C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12371 C XSTHR = ONE/ECM**2
12375 XSTHR = CSEA/ECM**2
12376 C XSTHR = ONE/ECM**2
12378 IF ((IP.GE.150).AND.(IT.GE.150))
12379 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12382 * (default: SSMIMA=0.14) used for sea-diquarks (?)
12383 XSSTHR = SSMIMA/ECM
12385 * valence-quarks (default: CVQ=1.0)
12387 * valence-diquarks (default: CDQ=2.0)
12390 * maximum-x for sea-quarks
12391 XVCUT = XVTHR+XDTHR
12392 IF (XVCUT.GT.XVMAX) THEN
12394 XVTHR = XVCUT/3.0D0
12395 XDTHR = XVCUT-XVTHR
12398 **sr 18.4. test: DPMJET
12399 C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12400 C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12401 C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12403 * maximum number of sea-pairs allowed kinematically
12404 C NSMAX = INT(OHALF*XXSEAM/XSTHR)
12405 RNSMAX = OHALF*XXSEAM/XSTHR
12406 IF (RNSMAX.GT.10000.0D0) THEN
12409 NSMAX = INT(OHALF*XXSEAM/XSTHR)
12411 * check kinematical limit for valence-x thresholds
12412 * (should be obsolete now)
12413 IF (XVCUT.GT.XVMAX) THEN
12414 WRITE(LOUT,1000) XVCUT,ECM
12415 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
12416 & ' thresholds not allowed (',2E9.3,')')
12417 C XVTHR = XVMAX-XDTHR
12418 C IF (XVTHR.LT.ZERO) STOP
12422 * set eta for valence-x sampling (BETREJ)
12423 * (UNON per default, UNOM used for projectile mesons only)
12424 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12430 * (2) select parton x-values of interacting projectile nucleons
12431 *-----------------------------------------------------------------------
12437 * get interacting projectile nucleon as sampled by Glauber
12438 IF (JSSH(IPP).NE.0) THEN
12444 * JIPP is the actual number of sea-pairs sampled for this nucleon
12445 JIPP = MIN(JSSH(IPP)-1,NSMAX)
12448 IF (JIPP.GT.0) THEN
12449 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12451 IF (XSTHR.GE.XSMAX) THEN
12456 *>>>get x-values of sea-quark pairs
12460 * accumulator for sea x-values
12463 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12464 IF (NSCOUN.GT.NSEA) THEN
12465 * decrease the number of interactions after NSEA trials
12471 IF (IPSQ(IXPS+1).LE.2) THEN
12472 **sr 8.4.98 (1/sqrt(x))
12473 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12474 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12475 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12478 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12479 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12481 **sr 8.4.98 (1/sqrt(x))
12482 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12483 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12484 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12489 IF (IPSAQ(IXPS+1).GE.-2) THEN
12490 **sr 8.4.98 (1/sqrt(x))
12491 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12492 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12493 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12496 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12497 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12499 **sr 8.4.98 (1/sqrt(x))
12500 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12501 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12502 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12506 XXSEA = XXSEA+XPSQI+XPSAQI
12507 * check for maximum allowed sea x-value
12508 IF (XXSEA.GE.XXSEAM) THEN
12512 * accept this sea-quark pair
12515 XPSAQ(IXPS) = XPSAQI
12517 ZUOSP(IXPS) = .TRUE.
12521 *>>>get x-values of valence partons
12523 IF (XVTHR.GT.0.05D0) THEN
12524 XVHI = ONE-XXSEA-XDTHR
12525 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12528 XPVQI = DT_DBETAR(OHALF,UNOPRV)
12529 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12533 XPVDI = ONE-XPVQI-XXSEA
12534 * reject according to x**1.5
12535 XDTMP = XPVDI**1.5D0
12536 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12537 * accept these valence partons
12543 ZUOVP(IXPV) = .TRUE.
12548 * (3) select parton x-values of interacting target nucleons
12549 *-----------------------------------------------------------------------
12555 * get interacting target nucleon as sampled by Glauber
12556 IF (JTSH(ITT).NE.0) THEN
12562 * JITT is the actual number of sea-pairs sampled for this nucleon
12563 JITT = MIN(JTSH(ITT)-1,NSMAX)
12566 IF (JITT.GT.0) THEN
12567 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12569 IF (XSTHR.GE.XSMAX) THEN
12574 *>>>get x-values of sea-quark pairs
12578 * accumulator for sea x-values
12581 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12582 IF (NSCOUN.GT.NSEA)THEN
12583 * decrease the number of interactions after NSEA trials
12589 IF (ITSQ(IXTS+1).LE.2) THEN
12590 **sr 8.4.98 (1/sqrt(x))
12591 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12592 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12593 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12596 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12597 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12599 **sr 8.4.98 (1/sqrt(x))
12600 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12601 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12602 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12607 IF (ITSAQ(IXTS+1).GE.-2) THEN
12608 **sr 8.4.98 (1/sqrt(x))
12609 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12610 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12611 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12614 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12615 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12617 **sr 8.4.98 (1/sqrt(x))
12618 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12619 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12620 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12624 XXSEA = XXSEA+XTSQI+XTSAQI
12625 * check for maximum allowed sea x-value
12626 IF (XXSEA.GE.XXSEAM) THEN
12630 * accept this sea-quark pair
12633 XTSAQ(IXTS) = XTSAQI
12635 ZUOST(IXTS) = .TRUE.
12639 *>>>get x-values of valence partons
12641 IF (XVTHR.GT.0.05D0) THEN
12642 XVHI = ONE-XXSEA-XDTHR
12643 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12646 XTVQI = DT_DBETAR(OHALF,UNON)
12647 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12651 XTVDI = ONE-XTVQI-XXSEA
12652 * reject according to x**1.5
12653 XDTMP = XTVDI**1.5D0
12654 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12655 * accept these valence partons
12661 ZUOVT(IXTV) = .TRUE.
12666 * (4) get valence-valence chains
12667 *-----------------------------------------------------------------------
12672 IPVAL = ITOVP(INTER1(I))
12673 ITVAL = ITOVT(INTER2(I))
12674 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12676 ZUOVP(IPVAL) = .FALSE.
12677 ZUOVT(ITVAL) = .FALSE.
12680 INTVV1(NVV) = IPVAL
12681 INTVV2(NVV) = ITVAL
12685 * (5) get sea-valence chains
12686 *-----------------------------------------------------------------------
12693 IPVAL = ITOVP(INTER1(I))
12694 ITVAL = ITOVT(INTER2(I))
12696 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12697 & ZUOVT(ITVAL)) THEN
12699 ZUOVT(ITVAL) = .FALSE.
12701 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12702 * sample sea-diquark pair
12703 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12704 IF (IREJ1.EQ.0) GOTO 260
12709 INTSV2(NSV) = ITVAL
12711 *>>>correct chain kinematics according to minimum chain masses
12712 * the actual chain masses
12713 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12714 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12715 * get lower mass cuts
12716 IF (IPSQ(J).EQ.3) THEN
12721 * q being u/d-quark
12726 * chain mass above minimum - resampling of sea-q x-value
12727 IF (AMSVQ1.GT.AMCHK1) THEN
12728 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
12729 **sr 8.4.98 (1/sqrt(x))
12730 C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
12731 C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
12732 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12734 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12736 * chain mass below minimum - reset sea-q x-value and correct
12737 * diquark-x of the same nucleon
12738 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12739 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
12740 DXPSQ = XPSQW-XPSQ(J)
12741 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12742 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12747 * chain mass below minimum - reset sea-aq x-value and correct
12748 * diquark-x of the same nucleon
12749 IF (AMSVQ2.LT.AMCHK2) THEN
12750 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12751 DXPSQ = XPSQW-XPSAQ(J)
12752 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12753 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12757 *>>>end of chain mass correction
12766 * (6) get valence-sea chains
12767 *-----------------------------------------------------------------------
12773 IPVAL = ITOVP(INTER1(I))
12774 ITVAL = ITOVT(INTER2(I))
12776 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12777 & (IFROST(J).EQ.INTER2(I))) THEN
12779 ZUOVP(IPVAL) = .FALSE.
12781 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12782 * sample sea-diquark pair
12783 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12784 IF (IREJ1.EQ.0) GOTO 290
12788 INTVS1(NVS) = IPVAL
12791 *>>>correct chain kinematics according to minimum chain masses
12792 * the actual chain masses
12793 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12794 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12795 * get lower mass cuts
12796 IF (ITSQ(J).EQ.3) THEN
12801 * q being u/d-quark
12806 * chain mass below minimum - reset sea-aq x-value and correct
12807 * diquark-x of the same nucleon
12808 IF (AMVSQ1.LT.AMCHK1) THEN
12809 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12810 DXTSQ = XTSQW-XTSAQ(J)
12811 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12812 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12817 * chain mass above minimum - resampling of sea-q x-value
12818 IF (AMVSQ2.GT.AMCHK2) THEN
12819 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
12820 **sr 8.4.98 (1/sqrt(x))
12821 C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
12822 C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
12823 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12825 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12827 * chain mass below minimum - reset sea-q x-value and correct
12828 * diquark-x of the same nucleon
12829 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12830 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
12831 DXTSQ = XTSQW-XTSQ(J)
12832 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12833 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12837 *>>>end of chain mass correction
12846 * (7) get sea-sea chains
12847 *-----------------------------------------------------------------------
12854 IPVAL = ITOVP(INTER1(I))
12855 ITVAL = ITOVT(INTER2(I))
12856 * loop over target partons not yet matched
12858 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12859 * loop over projectile partons not yet matched
12861 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12862 ZUOSP(JJ) = .FALSE.
12870 *---->chain recombination option
12871 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
12872 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12874 * sea-sea chains may recombine with valence-valence chains
12875 * only if they have the same projectile or target nucleon
12877 IF (ISKPCH(8,IVV).NE.99) THEN
12878 IXVPR = INTVV1(IVV)
12879 IXVTA = INTVV2(IVV)
12880 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12881 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12882 * recombination possible, drop old v-v and s-s chains
12886 * (a) assign new s-v chains
12887 * ~~~~~~~~~~~~~~~~~~~~~~~~~
12889 & (DT_RNDM(VALFRA).GT.FRCDIQ))
12891 * sample sea-diquark pair
12892 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12894 IF (IREJ1.EQ.0) GOTO 4202
12899 INTSV2(NSV) = IXVTA
12900 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12901 * the actual chain masses
12902 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12904 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12906 * get lower mass cuts
12907 IF (IPSQ(JJ).EQ.3) THEN
12912 * q being u/d-quark
12917 * chain mass above minimum - resampling of sea-q x-value
12918 IF (AMSVQ1.GT.AMCHK1) THEN
12920 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12921 **sr 8.4.98 (1/sqrt(x))
12923 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12924 C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
12925 C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
12928 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12930 * chain mass below minimum - reset sea-q x-value and correct
12931 * diquark-x of the same nucleon
12932 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12934 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12935 DXPSQ = XPSQW-XPSQ(JJ)
12936 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12939 & XPVD(IPVAL)-DXPSQ
12944 * chain mass below minimum - reset sea-aq x-value and correct
12945 * diquark-x of the same nucleon
12946 IF (AMSVQ2.LT.AMCHK2) THEN
12948 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
12949 DXPSQ = XPSQW-XPSAQ(JJ)
12950 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12953 & XPVD(IPVAL)-DXPSQ
12957 *>>>>>>>>>>>end of chain mass correction
12960 * (b) assign new v-s chains
12961 * ~~~~~~~~~~~~~~~~~~~~~~~~~
12963 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
12965 * sample sea-diquark pair
12966 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12968 IF (IREJ1.EQ.0) GOTO 4203
12972 INTVS1(NVS) = IXVPR
12974 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12975 * the actual chain masses
12976 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12977 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12978 * get lower mass cuts
12979 IF (ITSQ(J).EQ.3) THEN
12984 * q being u/d-quark
12989 * chain mass below minimum - reset sea-aq x-value and correct
12990 * diquark-x of the same nucleon
12991 IF (AMVSQ1.LT.AMCHK1) THEN
12993 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
12994 DXTSQ = XTSQW-XTSAQ(J)
12995 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12998 & XTVD(ITVAL)-DXTSQ
13002 IF (AMVSQ2.GT.AMCHK2) THEN
13004 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13005 **sr 8.4.98 (1/sqrt(x))
13007 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13008 C & DT_SAMSQX(XTSQTH,XTSQ(J))
13009 C & DT_SAMPEX(XTSQTH,XTSQ(J))
13012 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13014 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13016 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13017 DXTSQ = XTSQW-XTSQ(J)
13018 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13021 & XTVD(ITVAL)-DXTSQ
13025 *>>>>>>>>>end of chain mass correction
13027 * jump out of s-s chain loop
13033 *---->end of chain recombination option
13035 * sample sea-diquark pair (projectile)
13036 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13037 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13038 IF (IREJ1.EQ.0) THEN
13043 * sample sea-diquark pair (target)
13044 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13045 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13046 IF (IREJ1.EQ.0) THEN
13051 *>>>>>correct chain kinematics according to minimum chain masses
13052 * the actual chain masses
13053 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13054 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13055 * check for lower mass cuts
13056 IF ((SSMA1Q.LT.SSMIMQ).OR.
13057 & (SSMA2Q.LT.SSMIMQ)) THEN
13058 IPVAL = ITOVP(INTER1(I))
13059 ITVAL = ITOVT(INTER2(I))
13060 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13061 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13062 * maximum allowed x values for sea quarks
13063 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13065 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13067 * resampling of x values not possible - skip sea-sea chains
13068 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13069 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13070 * resampling of x for projectile sea quark pair
13074 IF (XSSTHR.GT.0.05D0) THEN
13075 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13077 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13081 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13082 IF ((XPSQI.LT.XSSTHR).OR.
13083 & (XPSQI.GT.XSPMAX)) GOTO 320
13085 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13086 IF ((XPSAQI.LT.XSSTHR).OR.
13087 & (XPSAQI.GT.XSPMAX)) GOTO 330
13089 * final test of remaining x for projectile diquark
13090 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13091 & +XPSQ(JJ)+XPSAQ(JJ)
13092 IF (XPVDCO.LE.XDTHR) THEN
13094 C IF (ICOUS.LT.5) GOTO 310
13095 IF (ICOUS.LT.0.5D0) GOTO 310
13098 * resampling of x for target sea quark pair
13102 IF (XSSTHR.GT.0.05D0) THEN
13103 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13105 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13109 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13110 IF ((XTSQI.LT.XSSTHR).OR.
13111 & (XTSQI.GT.XSTMAX)) GOTO 360
13113 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13114 IF ((XTSAQI.LT.XSSTHR).OR.
13115 & (XTSAQI.GT.XSTMAX)) GOTO 370
13117 * final test of remaining x for target diquark
13118 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13119 & +XTSQ(J)+XTSAQ(J)
13120 IF (XTVDCO.LT.XDTHR) THEN
13121 IF (ICOUS.LT.5) GOTO 350
13124 XPVD(IPVAL) = XPVDCO
13125 XTVD(ITVAL) = XTVDCO
13130 *>>>>>end of chain mass correction
13133 * come here to discard s-s interaction
13134 * resampling of x values not allowed or unsuccessful
13141 * consider next s-s interaction
13151 * correct x-values of valence quarks for non-matching sea quarks
13154 IPVAL = ITOVP(IFROSP(I))
13155 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13163 ITVAL = ITOVT(IFROST(I))
13164 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13171 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13174 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13180 *$ CREATE DT_SAMSDQ.FOR
13183 *===samsdq=============================================================*
13185 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13187 ************************************************************************
13188 * SAMpling of Sea-DiQuarks *
13189 * ECM cm-energy of the nucleon-nucleon system *
13190 * IDX1,2 indices of x-values of the participating *
13191 * partons (IDX2 is always the sea-q-pair to be *
13192 * changed to sea-qq-pair) *
13193 * MODE = 1 valence-q - sea-diq *
13194 * = 2 sea-diq - valence-q *
13195 * = 3 sea-q - sea-diq *
13196 * = 4 sea-diq - sea-q *
13197 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13198 * This version dated 17.10.95 is written by S. Roesler *
13199 ************************************************************************
13201 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13204 PARAMETER (ZERO=0.0D0)
13206 * threshold values for x-sampling (DTUNUC 1.x)
13207 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13209 * various options for treatment of partons (DTUNUC 1.x)
13210 * (chain recombination, Cronin,..)
13211 LOGICAL LCO2CR,LINTPT
13212 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13214 PARAMETER ( MAXNCL = 260,
13216 & MAXSQU = 20*MAXVQU,
13217 & MAXINT = MAXVQU+MAXSQU)
13218 * x-values of partons (DTUNUC 1.x)
13219 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13220 & XTVQ(MAXVQU),XTVD(MAXVQU),
13221 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13222 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13223 * flavors of partons (DTUNUC 1.x)
13224 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13225 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13226 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13227 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13228 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13229 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13230 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13231 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13232 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13233 & IXPV,IXPS,IXTV,IXTS,
13234 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13235 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13236 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13237 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13238 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13239 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13240 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13241 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13242 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13243 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13244 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13245 * auxiliary common for chain system storage (DTUNUC 1.x)
13246 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13249 * threshold-x for valence diquarks
13252 GOTO (1,2,3,4) MODE
13254 *---------------------------------------------------------------------
13255 * proj. valence partons - targ. sea partons
13256 * get x-values and flavors for target sea-diquark pair
13262 * index of corr. val-diquark-x in target nucleon
13263 IDXVT = ITOVT(IFROST(IDXST))
13264 * available x above diquark thresholds for valence- and sea-diquarks
13265 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13267 IF (XXD.GE.ZERO) THEN
13268 * x-values for the three diquarks of the target nucleon
13272 SR123 = RR1+RR2+RR3
13273 XXTV = XDTHR+RR1*XXD/SR123
13274 XXTSQ = XDTHR+RR2*XXD/SR123
13275 XXTSAQ = XDTHR+RR3*XXD/SR123
13278 XXTSQ = XTSQ(IDXST)
13279 XXTSAQ = XTSAQ(IDXST)
13281 * flavor of the second quarks in the sea-diquark pair
13282 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13283 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13284 * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13285 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13286 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13287 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13289 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13292 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13293 * at least one strange quark
13294 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13297 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13301 * accept the new sea-diquark
13303 XTSQ(IDXST) = XXTSQ
13304 XTSAQ(IDXST) = XXTSAQ
13306 INTVD1(NVD) = IDXVP
13307 INTVD2(NVD) = IDXST
13311 *---------------------------------------------------------------------
13312 * proj. sea partons - targ. valence partons
13313 * get x-values and flavors for projectile sea-diquark pair
13319 * index of corr. val-diquark-x in projectile nucleon
13320 IDXVP = ITOVP(IFROSP(IDXSP))
13321 * available x above diquark thresholds for valence- and sea-diquarks
13322 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13324 IF (XXD.GE.ZERO) THEN
13325 * x-values for the three diquarks of the projectile nucleon
13329 SR123 = RR1+RR2+RR3
13330 XXPV = XDTHR+RR1*XXD/SR123
13331 XXPSQ = XDTHR+RR2*XXD/SR123
13332 XXPSAQ = XDTHR+RR3*XXD/SR123
13335 XXPSQ = XPSQ(IDXSP)
13336 XXPSAQ = XPSAQ(IDXSP)
13338 * flavor of the second quarks in the sea-diquark pair
13339 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13340 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13341 * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13342 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13343 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13344 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13346 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13349 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13350 * at least one strange quark
13351 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13354 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13358 * accept the new sea-diquark
13360 XPSQ(IDXSP) = XXPSQ
13361 XPSAQ(IDXSP) = XXPSAQ
13363 INTDV1(NDV) = IDXSP
13364 INTDV2(NDV) = IDXVT
13368 *---------------------------------------------------------------------
13369 * proj. sea partons - targ. sea partons
13370 * get x-values and flavors for target sea-diquark pair
13376 * index of corr. val-diquark-x in target nucleon
13377 IDXVT = ITOVT(IFROST(IDXST))
13378 * available x above diquark thresholds for valence- and sea-diquarks
13379 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13381 IF (XXD.GE.ZERO) THEN
13382 * x-values for the three diquarks of the target nucleon
13386 SR123 = RR1+RR2+RR3
13387 XXTV = XDTHR+RR1*XXD/SR123
13388 XXTSQ = XDTHR+RR2*XXD/SR123
13389 XXTSAQ = XDTHR+RR3*XXD/SR123
13392 XXTSQ = XTSQ(IDXST)
13393 XXTSAQ = XTSAQ(IDXST)
13395 * flavor of the second quarks in the sea-diquark pair
13396 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13397 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13398 * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13399 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
13400 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13401 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13403 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13406 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13407 * at least one strange quark
13408 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13411 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13415 * accept the new sea-diquark
13417 XTSQ(IDXST) = XXTSQ
13418 XTSAQ(IDXST) = XXTSAQ
13420 INTSD1(NSD) = IDXSP
13421 INTSD2(NSD) = IDXST
13425 *---------------------------------------------------------------------
13426 * proj. sea partons - targ. sea partons
13427 * get x-values and flavors for projectile sea-diquark pair
13433 * index of corr. val-diquark-x in projectile nucleon
13434 IDXVP = ITOVP(IFROSP(IDXSP))
13435 * available x above diquark thresholds for valence- and sea-diquarks
13436 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13438 IF (XXD.GE.ZERO) THEN
13439 * x-values for the three diquarks of the projectile nucleon
13443 SR123 = RR1+RR2+RR3
13444 XXPV = XDTHR+RR1*XXD/SR123
13445 XXPSQ = XDTHR+RR2*XXD/SR123
13446 XXPSAQ = XDTHR+RR3*XXD/SR123
13449 XXPSQ = XPSQ(IDXSP)
13450 XXPSAQ = XPSAQ(IDXSP)
13452 * flavor of the second quarks in the sea-diquark pair
13453 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13454 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13455 * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13456 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
13457 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
13458 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13460 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13463 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13464 * at least one strange quark
13465 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13468 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13472 * accept the new sea-diquark
13474 XPSQ(IDXSP) = XXPSQ
13475 XPSAQ(IDXSP) = XXPSAQ
13477 INTDS1(NDS) = IDXSP
13478 INTDS2(NDS) = IDXST
13483 *$ CREATE DT_DIFEVT.FOR
13486 *===difevt=============================================================*
13488 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13489 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13491 ************************************************************************
13492 * Interface to treatment of diffractive interactions. *
13493 * (input) IFP1/2 PDG-indizes of projectile partons *
13494 * (baryon: IFP2 - adiquark) *
13495 * PP(4) projectile 4-momentum *
13496 * IFT1/2 PDG-indizes of target partons *
13497 * (baryon: IFT1 - adiquark) *
13498 * PT(4) target 4-momentum *
13499 * (output) JDIFF = 0 no diffraction *
13500 * = 1/-1 LMSD/LMDD *
13501 * = 2/-2 HMSD/HMDD *
13502 * NCSY counter for two-chain systems *
13503 * dumped to DTEVT1 *
13504 * This version dated 14.02.95 is written by S. Roesler *
13505 ************************************************************************
13507 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13509 PARAMETER ( LINP = 10 ,
13512 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13516 PARAMETER (NMXHKK=200000)
13517 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13518 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13519 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13520 * extended event history
13521 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13522 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13524 * flags for diffractive interactions (DTUNUC 1.x)
13525 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13527 DIMENSION PP(4),PT(4)
13530 DATA LFIRST /.TRUE./
13537 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13538 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13539 * identities of projectile hadron / target nucleon
13540 KPROJ = IDT_ICIHAD(IDHKK(MOP))
13541 KTARG = IDT_ICIHAD(IDHKK(MOT))
13543 * single diffractive xsections
13544 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13545 * double diffractive xsections
13546 **!! no double diff yet
13547 C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13551 * total inelastic xsection
13552 C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13554 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13555 SIGIN = MAX(SIGTO-SIGEL,ZERO)
13557 * fraction of diffractive processes
13558 FRADIF = (SDTOT+DDTOT)/SIGIN
13561 WRITE(LOUT,1000) XM,SDTOT,SIGIN
13562 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13563 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13568 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13569 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13570 * diffractive interaction requested by x-section or by user
13571 FRASD = SDTOT/(SDTOT+DDTOT)
13572 FRASDH = SDHM/SDTOT
13573 **sr needs to be specified!!
13574 C FRADDH = DDHM/DDTOT
13577 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13578 * single diffraction
13580 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13583 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13584 & ISINGD.NE.3) THEN
13591 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13592 & ISINGD.NE.3) THEN
13598 * double diffraction
13600 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13608 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13609 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13610 IF (IREJ1.EQ.0) THEN
13612 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13626 *$ CREATE DT_DIFFKI.FOR
13629 *===difkin=============================================================*
13631 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13632 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13634 ************************************************************************
13635 * Kinematics of diffractive nucleon-nucleon interaction. *
13636 * IFP1/2 PDG-indizes of projectile partons *
13637 * (baryon: IFP2 - adiquark) *
13638 * PP(4) projectile 4-momentum *
13639 * IFT1/2 PDG-indizes of target partons *
13640 * (baryon: IFT1 - adiquark) *
13641 * PT(4) target 4-momentum *
13642 * KP = 0 projectile quasi-elastically scattered *
13643 * = 1 excited to low-mass diff. state *
13644 * = 2 excited to high-mass diff. state *
13645 * KT = 0 target quasi-elastically scattered *
13646 * = 1 excited to low-mass diff. state *
13647 * = 2 excited to high-mass diff. state *
13648 * This version dated 12.02.95 is written by S. Roesler *
13649 ************************************************************************
13651 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13653 PARAMETER ( LINP = 10 ,
13656 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13660 * particle properties (BAMJET index convention)
13662 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13663 & IICH(210),IIBAR(210),K1(210),K2(210)
13664 * flags for input different options
13665 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13666 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13667 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13668 * rejection counter
13669 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13670 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13671 & IREXCI(3),IRDIFF(2),IRINC
13672 * kinematics of diffractive interactions (DTUNUC 1.x)
13673 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13675 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13676 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13678 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13679 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13681 DATA LSTART /.TRUE./
13685 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
13691 * initialize common /DTDIKI/
13693 * store momenta of initial incoming particles for emc-check
13695 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13696 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13699 * masses of initial particles
13700 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13701 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13702 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13705 * check quark-input (used to adjust coherence cond. for M-selection)
13707 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13709 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13711 * parameter for Lorentz-transformation into nucleon-nucleon cms
13713 PITOT(K) = PP(K)+PT(K)
13715 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13716 IF (XMTOT2.LE.ZERO) THEN
13717 WRITE(LOUT,1000) XMTOT2
13718 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
13719 & 'XMTOT2 = ',E12.3)
13722 XMTOT = SQRT(XMTOT2)
13724 BGTOT(K) = PITOT(K)/XMTOT
13726 * transformation of nucleons into cms
13727 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13728 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13729 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13730 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13733 C SID = SQRT((ONE-COD)*(ONE+COD))
13734 PPT = SQRT(PP1(1)**2+PP1(2)**2)
13738 IF(PPTOT*SID.GT.TINY10) THEN
13739 COF = PP1(1)/(SID*PPTOT)
13740 SIF = PP1(2)/(SID*PPTOT)
13741 ANORF = SQRT(COF*COF+SIF*SIF)
13745 * check consistency
13747 DEV1(K) = ABS(PP1(K)+PT1(K))
13749 DEV1(4) = ABS(DEV1(4)-XMTOT)
13750 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13751 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
13752 WRITE(LOUT,1001) DEV1
13753 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
13758 * select x-fractions in high-mass diff. interactions
13759 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13761 * select diffractive masses
13764 XMPF = DT_XMLMD(XMTOT)
13765 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13766 IF (IREJ1.GT.0) GOTO 9999
13767 ELSEIF (KP.EQ.2) THEN
13768 XMPF = DT_XMHMD(XMTOT,IBP,1)
13774 XMTF = DT_XMLMD(XMTOT)
13775 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13776 IF (IREJ1.GT.0) GOTO 9999
13777 ELSEIF (KT.EQ.2) THEN
13778 XMTF = DT_XMHMD(XMTOT,IBT,2)
13783 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13786 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13787 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13789 * select momentum transfer (all t-values used here are <0)
13790 * minimum absolute value to produce diffractive masses
13791 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13792 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13793 IF (IREJ1.GT.0) GOTO 9999
13795 * longitudinal momentum of excited/elastically scattered projectile
13796 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13797 * total transverse momentum due to t-selection
13798 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13799 IF (PPBLT2.LT.ZERO) THEN
13800 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13801 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
13802 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13805 CALL DT_DSFECF(SINPHI,COSPHI)
13806 PPBLT = SQRT(PPBLT2)
13807 PPBLOB(1) = COSPHI*PPBLT
13808 PPBLOB(2) = SINPHI*PPBLT
13810 * rotate excited/elastically scattered projectile into n-n cms.
13811 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13817 * 4-momentum of excited/elastically scattered target and of exchanged
13820 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13821 PPOM1(K) = PP1(K)-PPBLOB(K)
13823 PTBLOB(4) = XMTOT-PPBLOB(4)
13825 * Lorentz-transformation back into system of initial diff. collision
13826 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13827 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13828 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13829 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13830 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13831 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13832 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13833 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13834 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13836 * store 4-momentum of elastically scattered particle (in single diff.
13842 ELSEIF (KT.EQ.0) THEN
13848 * check consistency of kinematical treatment so far
13850 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13851 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13852 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13853 IF (IREJ1.NE.0) GOTO 9999
13856 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13857 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13859 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13860 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13861 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13862 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
13863 WRITE(LOUT,1003) DEV1,DEV2
13864 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
13869 * kinematical treatment for low-mass diffraction
13870 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13871 IF (IREJ1.NE.0) GOTO 9999
13873 * dump diffractive chains into DTEVT1
13874 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13875 IF (IREJ1.NE.0) GOTO 9999
13880 IRDIFF(1) = IRDIFF(1)+1
13885 *$ CREATE DT_XMHMD.FOR
13888 *===xmhmd==============================================================*
13890 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13892 ************************************************************************
13893 * Diffractive mass in high mass single/double diffractive events. *
13894 * This version dated 11.02.95 is written by S. Roesler *
13895 ************************************************************************
13897 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13899 PARAMETER ( LINP = 10 ,
13902 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13904 * kinematics of diffractive interactions (DTUNUC 1.x)
13905 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13907 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13908 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13910 C DATA XCOLOW /0.05D0/
13911 DATA XCOLOW /0.15D0/
13915 IF (MODE.EQ.2) XH = XTH(2)
13917 * minimum Pomeron-x for high-mass diffraction
13918 * (adjusted to get a smooth transition between HM and LM component)
13920 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13921 IF (ECM.LE.300.0D0) THEN
13922 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13923 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13925 * maximum Pomeron-x for high-mass diffraction
13926 * (coherence condition, adjusted to fit to experimental data)
13928 * baryon-diffraction
13929 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13931 * meson-diffraction
13932 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13935 IF (XDIMIN.GE.XDIMAX) THEN
13936 XDIMIN = OHALF*XDIMAX
13942 IF (KLOOP.GT.20) RETURN
13943 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
13944 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13945 * corr. diffr. mass
13946 DT_XMHMD = ECM*SQRT(XDIFF)
13947 IF (DT_XMHMD.LT.2.5D0) GOTO 1
13952 *$ CREATE DT_XMLMD.FOR
13955 *===xmlmd==============================================================*
13957 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13959 ************************************************************************
13960 * Diffractive mass in high mass single/double diffractive events. *
13961 * This version dated 11.02.95 is written by S. Roesler *
13962 ************************************************************************
13964 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13966 PARAMETER ( LINP = 10 ,
13970 * minimum Pomeron-x for low-mass diffraction
13973 * maximum Pomeron-x for low-mass diffraction
13974 * (adjusted to get a smooth transition between HM and LM component)
13977 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13978 R = DT_RNDM(AMO)*SAM
13979 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13980 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13982 * selection of diffractive mass
13983 * (adjusted to get a smooth transition between HM and LM component)
13985 IF (ECM.LE.50.0D0) THEN
13986 DT_XMLMD = AMO*(AMU/AMO)**R
13989 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
13990 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
13996 *$ CREATE DT_TDIFF.FOR
13999 *===tdiff==============================================================*
14001 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14003 ************************************************************************
14004 * t-selection for single/double diffractive interactions. *
14006 * TMIN minimum momentum transfer to produce diff. masses *
14007 * XM1/XM2 diffractively produced masses *
14008 * (for single diffraction XM2 is obsolete) *
14009 * K1/K2= 0 not excited *
14010 * = 1 low-mass excitation *
14011 * = 2 high-mass excitation *
14012 * This version dated 11.02.95 is written by S. Roesler *
14013 ************************************************************************
14015 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14017 PARAMETER ( LINP = 10 ,
14020 PARAMETER (ZERO=0.0D0)
14022 PARAMETER ( BTP0 = 3.7D0,
14023 & ALPHAP = 0.24D0 )
14036 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14037 * slope for single diffraction
14038 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14040 * slope for double diffraction
14041 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14046 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14048 T = -LOG(1.0D0-Y)/SLOPE
14049 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14055 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14056 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14057 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14058 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14063 *$ CREATE DT_XVALHM.FOR
14066 *===xvalhm=============================================================*
14068 SUBROUTINE DT_XVALHM(KP,KT)
14070 ************************************************************************
14071 * Sampling of parton x-values in high-mass diffractive interactions. *
14072 * This version dated 12.02.95 is written by S. Roesler *
14073 ************************************************************************
14075 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14077 PARAMETER ( LINP = 10 ,
14080 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14082 * kinematics of diffractive interactions (DTUNUC 1.x)
14083 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14085 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14086 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14087 * various options for treatment of partons (DTUNUC 1.x)
14088 * (chain recombination, Cronin,..)
14089 LOGICAL LCO2CR,LINTPT
14090 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14093 DATA UNON,XVQTHR /2.0D0,0.8D0/
14096 * x-fractions of projectile valence partons
14098 XPH(1) = DT_DBETAR(OHALF,UNON)
14099 IF (XPH(1).GE.XVQTHR) GOTO 1
14100 XPH(2) = ONE-XPH(1)
14101 * x-fractions of Pomeron q-aq-pair
14104 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14105 XPPO(2) = ONE-XPPO(1)
14106 * flavors of Pomeron q-aq-pair
14107 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14110 IF (DT_RNDM(UNON).GT.OHALF) THEN
14117 * x-fractions of projectile target partons
14119 XTH(1) = DT_DBETAR(OHALF,UNON)
14120 IF (XTH(1).GE.XVQTHR) GOTO 2
14121 XTH(2) = ONE-XTH(1)
14122 * x-fractions of Pomeron q-aq-pair
14125 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14126 XTPO(2) = ONE-XTPO(1)
14127 * flavors of Pomeron q-aq-pair
14128 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14131 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14140 *$ CREATE DT_LM2RES.FOR
14143 *===lm2res=============================================================*
14145 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14147 ************************************************************************
14148 * Check low-mass diffractive excitation for resonance mass. *
14149 * (input) IF1/2 PDG-indizes of valence partons *
14150 * (in/out) XM diffractive mass requested/corrected *
14151 * (output) IDR/IDXR id./BAMJET-index of resonance *
14152 * This version dated 12.02.95 is written by S. Roesler *
14153 ************************************************************************
14155 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14157 PARAMETER ( LINP = 10 ,
14160 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14162 * kinematics of diffractive interactions (DTUNUC 1.x)
14163 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14165 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14166 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14173 * BAMJET indices of partons
14174 IF1A = IDT_IPDG2B(IF1,1,2)
14175 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14176 IF2A = IDT_IPDG2B(IF2,1,2)
14177 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14179 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14181 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14183 * check for resonance mass
14184 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14185 IF (IREJ1.NE.0) GOTO 9999
14195 *$ CREATE DT_LMKINE.FOR
14198 *===lmkine=============================================================*
14200 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14202 ************************************************************************
14203 * Kinematical treatment of low-mass excitations. *
14204 * This version dated 12.02.95 is written by S. Roesler *
14205 ************************************************************************
14207 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14209 PARAMETER ( LINP = 10 ,
14212 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14214 * flags for input different options
14215 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14216 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14217 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14218 * kinematics of diffractive interactions (DTUNUC 1.x)
14219 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14221 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14222 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14224 DIMENSION P1(4),P2(4)
14229 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14231 FAC1 = OHALF*(POE+ONE)
14232 FAC2 = -OHALF*(POE-ONE)
14234 PPLM1(K) = FAC1*PPF(K)
14235 PPLM2(K) = FAC2*PPF(K)
14237 PPLM1(4) = FAC1*PABS
14238 PPLM2(4) = -FAC2*PABS
14239 IF (IMSHL.EQ.1) THEN
14242 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14243 IF (IREJ1.NE.0) GOTO 9999
14252 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14254 FAC1 = OHALF*(POE+ONE)
14255 FAC2 = -OHALF*(POE-ONE)
14257 PTLM2(K) = FAC1*PTF(K)
14258 PTLM1(K) = FAC2*PTF(K)
14260 PTLM2(4) = FAC1*PABS
14261 PTLM1(4) = -FAC2*PABS
14262 IF (IMSHL.EQ.1) THEN
14265 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14266 IF (IREJ1.NE.0) GOTO 9999
14277 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14282 *$ CREATE DT_DIFINI.FOR
14285 *===difini=============================================================*
14287 SUBROUTINE DT_DIFINI
14289 ************************************************************************
14290 * Initialization of common /DTDIKI/ *
14291 * This version dated 12.02.95 is written by S. Roesler *
14292 ************************************************************************
14294 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14296 PARAMETER ( LINP = 10 ,
14299 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14301 * kinematics of diffractive interactions (DTUNUC 1.x)
14302 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14304 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14305 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14333 *$ CREATE DT_DIFPUT.FOR
14336 *===difput=============================================================*
14338 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14341 ************************************************************************
14342 * Dump diffractive chains into DTEVT1 *
14343 * This version dated 12.02.95 is written by S. Roesler *
14344 ************************************************************************
14346 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14348 PARAMETER ( LINP = 10 ,
14351 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14355 * kinematics of diffractive interactions (DTUNUC 1.x)
14356 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14358 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14359 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14361 PARAMETER (NMXHKK=200000)
14362 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14363 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14364 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14365 * extended event history
14366 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14367 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14369 * rejection counter
14370 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14371 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14372 & IREXCI(3),IRDIFF(2),IRINC
14374 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14375 & P1(4),P2(4),P3(4),P4(4)
14381 PCH(K) = PPLM1(K)+PPLM2(K)
14385 IF (DT_RNDM(PT).GT.OHALF) THEN
14389 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14391 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14393 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14395 ELSEIF (KP.EQ.2) THEN
14397 PP1(K) = XPH(1)*PP(K)
14398 PP2(K) = XPH(2)*PP(K)
14399 PT1(K) = -XPPO(1)*PPOM(K)
14400 PT2(K) = -XPPO(2)*PPOM(K)
14402 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14406 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14407 IF (IREJ1.NE.0) GOTO 9999
14408 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14409 IF (IREJ1.NE.0) GOTO 9999
14416 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14418 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14420 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14422 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14425 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14426 IF (IREJ1.NE.0) GOTO 9999
14427 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14428 IF (IREJ1.NE.0) GOTO 9999
14435 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14437 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14439 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14441 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14446 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14452 PCH(K) = PTLM1(K)+PTLM2(K)
14456 IF (DT_RNDM(PT).GT.OHALF) THEN
14460 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14462 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14464 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14466 ELSEIF (KT.EQ.2) THEN
14468 PP1(K) = XTPO(1)*PPOM(K)
14469 PP2(K) = XTPO(2)*PPOM(K)
14470 PT1(K) = XTH(2)*PT(K)
14471 PT2(K) = XTH(1)*PT(K)
14473 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14477 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14478 IF (IREJ1.NE.0) GOTO 9999
14479 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14480 IF (IREJ1.NE.0) GOTO 9999
14487 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14489 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14491 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14493 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14496 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14497 IF (IREJ1.NE.0) GOTO 9999
14498 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14499 IF (IREJ1.NE.0) GOTO 9999
14506 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14508 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14510 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14512 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14517 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14524 IRDIFF(2) = IRDIFF(2)+1
14529 *$ CREATE DT_EVTFRG.FOR
14532 *===evtfrg=============================================================*
14534 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14536 ************************************************************************
14537 * Hadronization of chains in DTEVT1. *
14540 * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
14541 * = 2 hadronization of DTUNUC-chains (id=88xxx) *
14542 * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
14543 * hadronized with one PYEXEC call *
14544 * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14545 * with one PYEXEC call *
14547 * NPYMEM number of entries in JETSET-common after hadronization *
14548 * IREJ rejection flag *
14550 * This version dated 17.09.00 is written by S. Roesler *
14551 ************************************************************************
14553 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14555 PARAMETER ( LINP = 10 ,
14558 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14559 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14563 PARAMETER (MXJOIN=200)
14566 PARAMETER (NMXHKK=200000)
14567 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14568 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14569 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14570 * extended event history
14571 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14572 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14574 * flags for input different options
14575 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14576 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14577 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14579 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14580 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14582 * flags for diffractive interactions (DTUNUC 1.x)
14583 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14584 * nucleon-nucleon event-generator
14587 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14589 C model switches and parameters
14591 INTEGER ISWMDL,IPAMDL
14592 DOUBLE PRECISION PARMDL
14593 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14595 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14596 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
14597 PARAMETER (MAXLND=4000)
14598 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14600 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14604 IF (MODE.NE.1) ISTSTG = 8
14613 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14614 DO 10 I=NPOINT(3),NEND
14615 * sr 14.02.00: seems to be not necessary anymore, commented
14616 C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14617 C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14619 * pick up chains from dtevt1
14620 IDCHK = IDHKK(I)/10000
14621 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14622 IF (IDCHK.EQ.7) THEN
14623 IPJE = IDHKK(I)-IDCHK*10000
14624 IF (IPJE.NE.IFRG) THEN
14626 IF (IFRG.GT.NFRG) GOTO 16
14631 IF (IFRG.GT.NFRG) THEN
14636 * statistics counter
14637 c IF (IDCH(I).LE.8)
14638 c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14639 c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14640 * special treatment for small chains already corrected to hadrons
14641 IF (IDRES(I).NE.0) THEN
14642 IF (IDRES(I).EQ.11) THEN
14645 ID = IDT_IPDGHA(IDXRES(I))
14648 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14649 & PHKK(4,I),INIEMC,IDUM,IDUM)
14653 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14654 P(IP,1) = PHKK(1,I)
14655 P(IP,2) = PHKK(2,I)
14656 P(IP,3) = PHKK(3,I)
14657 P(IP,4) = PHKK(4,I)
14658 P(IP,5) = PHKK(5,I)
14664 IHIST(2,I) = 10000*IPJE+IP
14665 IF (IHIST(1,I).LE.-100) THEN
14667 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14674 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14676 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14677 & PHKK(4,KK),INIEMC,IDUM,IDUM)
14678 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14682 IF (ID.EQ.0) ID = 21
14683 c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14684 c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14685 c AMRQ = PYMASS(ID)
14686 c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14687 c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14688 c & (ABS(IDIFF).EQ.0)) THEN
14689 cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14690 c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14691 c PHKK(4,KK) = PHKK(4,KK)+DELTA
14692 c PTOT1 = PTOT-DELTA
14693 c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14694 c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14695 c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14696 c PHKK(5,KK) = AMRQ
14699 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14700 P(IP,1) = PHKK(1,KK)
14701 P(IP,2) = PHKK(2,KK)
14702 P(IP,3) = PHKK(3,KK)
14703 P(IP,4) = PHKK(4,KK)
14704 P(IP,5) = PHKK(5,KK)
14710 IHIST(2,KK) = 10000*IPJE+IP
14711 IF (IHIST(1,KK).LE.-100) THEN
14713 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14717 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14722 * join the two-parton system
14723 CALL PYJOIN(IJ,IJOIN)
14733 * final state parton shower
14735 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14736 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14738 IF (ISJOIN(K1).EQ.0) GOTO 130
14740 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14742 IH1 = IHIST(2,I)/10000
14743 IF (IH1.NE.NPJE) GOTO 130
14744 IH1 = IHIST(2,I)-IH1*10000
14746 IF (ISJOIN(K2).EQ.0) GOTO 135
14748 IH2 = IHIST(2,II)/10000
14749 IF (IH2.NE.NPJE) GOTO 135
14750 IH2 = IHIST(2,II)-IH2*10000
14751 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14752 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14753 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14754 RQLUN = MIN(PT1,PT2)
14755 CALL PYSHOW(IH1,IH2,RQLUN)
14767 CALL DT_INITJS(MODE)
14772 IF (MSTU(24).NE.0) THEN
14773 WRITE(LOUT,*) ' JETSET-reject at event',
14774 & NEVHKK,MSTU(24),KMODE
14775 C CALL DT_EVTOUT(4)
14782 * number of entries in LUJETS
14794 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14796 * pick up mother resonance if possible and put it together with
14797 * their decay-products into the common
14799 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14800 KFMOR = K(IDXMOR,2)
14801 ISMOR = K(IDXMOR,1)
14806 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14807 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14809 MO = IHISMO(PYK(IDXMOR,15))
14814 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14817 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14818 IF (PYK(JDAUG,7).EQ.1) THEN
14824 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14830 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14836 * there was no mother resonance
14837 MO = IHISMO(PYK(II,15))
14843 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14849 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14856 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14857 C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14860 * global energy-momentum & flavor conservation check
14861 **sr 16.5. this check is skipped in case of phojet-treatment
14863 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14865 * update statistics-counter for diffraction
14866 c IF (IFLAGD.NE.0) THEN
14867 c ICDIFF(1) = ICDIFF(1)+1
14868 c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14869 c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14870 c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14871 c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14883 *$ CREATE DT_DECAYS.FOR
14886 *===decay==============================================================*
14888 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14890 ************************************************************************
14891 * Resonance-decay. *
14892 * This subroutine replaces DDECAY/DECHKK. *
14893 * PIN(4) 4-momentum of resonance (input) *
14894 * IDXIN BAMJET-index of resonance (input) *
14895 * POUT(20,4) 4-momenta of decay-products (output) *
14896 * IDXOUT(20) BAMJET-indices of decay-products (output) *
14897 * NSEC number of secondaries (output) *
14898 * Adopted from the original version DECHKK. *
14899 * This version dated 09.01.95 is written by S. Roesler *
14900 ************************************************************************
14902 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14904 PARAMETER ( LINP = 10 ,
14907 PARAMETER (TINY17=1.0D-17)
14909 * HADRIN: decay channel information
14910 PARAMETER (IDMAX9=602)
14912 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14913 * particle properties (BAMJET index convention)
14915 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14916 & IICH(210),IIBAR(210),K1(210),K2(210)
14917 * flags for input different options
14918 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14919 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14920 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14922 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14923 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14924 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14926 * ISTAB = 1 strong and weak decays
14927 * = 2 strong decays only
14928 * = 3 strong decays, weak decays for charmed particles and tau
14934 * put initial resonance to stack
14936 IDXSTK(NSTK) = IDXIN
14938 PI(NSTK,I) = PIN(I)
14941 * store initial configuration for energy-momentum cons. check
14942 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14943 & PI(NSTK,4),1,IDUM,IDUM)
14946 * get particle from stack
14947 IDXI = IDXSTK(NSTK)
14948 * skip stable particles
14949 IF (ISTAB.EQ.1) THEN
14950 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14951 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
14952 ELSEIF (ISTAB.EQ.2) THEN
14953 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
14954 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14955 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14956 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14957 IF ( IDXI.EQ.109) GOTO 10
14958 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14959 ELSEIF (ISTAB.EQ.3) THEN
14960 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
14961 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14962 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14963 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14966 * calculate direction cosines and Lorentz-parameter of decaying part.
14967 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14968 PTOT = MAX(PTOT,TINY17)
14970 DCOS(I) = PI(NSTK,I)/PTOT
14972 GAM = PI(NSTK,4)/AAM(IDXI)
14973 BGAM = PTOT/AAM(IDXI)
14975 * get decay-channel
14979 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14981 * identities of secondaries
14982 IDX(1) = NZK(KCHAN,1)
14983 IDX(2) = NZK(KCHAN,2)
14984 IF (IDX(2).LT.1) GOTO 9999
14985 IDX(3) = NZK(KCHAN,3)
14987 * handle decay in rest system of decaying particle
14988 IF (IDX(3).EQ.0) THEN
14989 * two-particle decay
14991 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
14992 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14993 & AAM(IDX(1)),AAM(IDX(2)))
14995 * three-particle decay
14997 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
14998 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14999 & CODF(3),COFF(3),SIFF(3),
15000 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15004 * transform decay products back
15007 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15008 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15009 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15010 * add particle to stack
15011 IDXSTK(NSTK) = IDX(I)
15013 PI(NSTK,J) = DCOSF(J)*PFF(I)
15019 * stable particle, put to output-arrays
15022 POUT(NSEC,I) = PI(NSTK,I)
15024 IDXOUT(NSEC) = IDXSTK(NSTK)
15025 * store secondaries for energy-momentum conservation check
15027 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15028 & -POUT(NSEC,4),2,IDUM,IDUM)
15030 IF (NSTK.GT.0) GOTO 100
15032 * check energy-momentum conservation
15034 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15035 IF (IREJ1.NE.0) GOTO 9999
15045 *$ CREATE DT_DECAY1.FOR
15048 *===decay1=============================================================*
15050 SUBROUTINE DT_DECAY1
15052 ************************************************************************
15053 * Decay of resonances stored in DTEVT1. *
15054 * This version dated 20.01.95 is written by S. Roesler *
15055 ************************************************************************
15057 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15059 PARAMETER ( LINP = 10 ,
15064 PARAMETER (NMXHKK=200000)
15065 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15066 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15067 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15068 * extended event history
15069 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15070 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15073 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15076 C DO 1 I=NPOINT(5),NEND
15077 DO 1 I=NPOINT(4),NEND
15078 IF (ABS(ISTHKK(I)).EQ.1) THEN
15083 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15084 IF (NSEC.GT.1) THEN
15086 IDHAD = IDT_IPDGHA(IDXOUT(N))
15087 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15088 & POUT(N,3),POUT(N,4),0,0,0)
15097 *$ CREATE DT_DECPI0.FOR
15100 *===decpi0=============================================================*
15102 SUBROUTINE DT_DECPI0
15104 ************************************************************************
15105 * Decay of pi0 handled with JETSET. *
15106 * This version dated 18.02.96 is written by S. Roesler *
15107 ************************************************************************
15109 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15111 PARAMETER ( LINP = 10 ,
15114 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15117 PARAMETER (NMXHKK=200000)
15118 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15119 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15120 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15121 * extended event history
15122 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15123 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15125 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15126 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15127 PARAMETER (MAXLND=4000)
15128 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15129 * flags for input different options
15130 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15131 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15132 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15136 DIMENSION IHISMO(NMXHKK),P1(4)
15138 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15148 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15154 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15155 & PHKK(4,I),INI,IDUM,IDUM)
15156 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15157 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15158 COSTH = PHKK(3,I)/(PTOT+TINY10)
15159 IF (COSTH.GT.ONE) THEN
15161 ELSEIF (COSTH.LT.-ONE) THEN
15162 THETA = TWOPI/2.0D0
15164 THETA = ACOS(COSTH)
15166 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15167 IF (PHKK(1,I).LT.0.0D0)
15168 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15173 P(NN,5) = PHKK(5,I)
15174 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15183 IF (PYK(II,7).EQ.1) THEN
15185 P1(KK) = PYP(II,KK)
15188 MO = IHISMO(PYK(II,15))
15189 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15191 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15193 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15197 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15204 *$ CREATE DT_DTWOPD.FOR
15207 *===dtwopd=============================================================*
15209 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15210 & COF2,SIF2,AM1,AM2)
15212 ************************************************************************
15213 * Two-particle decay. *
15214 * UMO cm-energy of the decaying system (input) *
15215 * AM1/AM2 masses of the decay products (input) *
15216 * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15217 * COD,COF,SIF direction cosines of the decay prod. (output) *
15218 * Revised by S. Roesler, 20.11.95 *
15219 ************************************************************************
15221 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15223 PARAMETER ( LINP = 10 ,
15226 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15228 IF (UMO.LT.(AM1+AM2)) THEN
15229 WRITE(LOUT,1000) UMO,AM1,AM2
15230 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15235 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15237 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15239 CALL DT_DSFECF(SIF1,COF1)
15240 COD1 = TWO*DT_RNDM(PCM2)-ONE
15248 *$ CREATE DT_DTHREP.FOR
15251 *===dthrep=============================================================*
15253 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15254 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15256 ************************************************************************
15257 * Three-particle decay. *
15258 * UMO cm-energy of the decaying system (input) *
15259 * AM1/2/3 masses of the decay products (input) *
15260 * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15261 * COD,COF,SIF direction cosines of the decay prod. (output) *
15263 * Threpd89: slight revision by A. Ferrari *
15264 * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15265 * Revised by S. Roesler, 20.11.95 *
15266 ************************************************************************
15268 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15270 PARAMETER ( LINP = 10 ,
15274 PARAMETER ( ANGLSQ = 2.5D-31 )
15275 PARAMETER ( AZRZRZ = 1.0D-30 )
15276 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15277 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15278 PARAMETER ( ONEONE = 1.D+00 )
15279 PARAMETER ( TWOTWO = 2.D+00 )
15280 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15282 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15283 * flags for input different options
15284 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15285 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15286 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15288 DIMENSION F(5),XX(5)
15292 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15293 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15294 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15301 * UFAK=1.0000000000001D0
15302 * IF (GU.GT.GO) UFAK=0.9999999999999D0
15320 S22=GU+(I-1.D0)*DS2
15322 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15324 IF(RHO2.LT.RHO1) GO TO 125
15326 125 S2SUP=(S22-S21)*.5D0+S21
15327 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15329 SUPRHO=SUPRHO*1.05D0
15331 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15332 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15338 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15339 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15341 X4=(XX(1)+XX(2))*0.5D0
15342 X5=(XX(2)+XX(3))*0.5D0
15343 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15345 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15352 IF (F (II).GE.F (III)) GO TO 128
15365 IF (XX(II).GE.XX(III)) GO TO 129
15379 IF (ITH.GT.200) REDU=-9.D0
15380 IF (ITH.GT.200) GO TO 400
15382 * S2=AM23+C*((UMO-AM1)**2-AM23)
15383 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15386 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15387 IF(Y.GT.RHO) GO TO 1
15388 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15390 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15392 S3=UMO2+AM11+AM22+AM33-S1-S2
15393 ECM1=(UMO2+AM11-S2)/UMOO
15394 ECM2=(UMO2+AM22-S3)/UMOO
15395 ECM3=(UMO2+AM33-S1)/UMOO
15396 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15397 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15398 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15399 CALL DT_DSFECF(SFE,CFE)
15400 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15401 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15402 PCM12 = PCM1 * PCM2
15403 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15404 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15408 COSTH=(UW-0.5D+00)*2.D+00
15410 * IF(ABS(COSTH).GT.0.9999999999999999D0)
15411 * &COSTH=SIGN(0.9999999999999999D0,COSTH)
15412 IF(ABS(COSTH).GT.ONEONE)
15413 &COSTH=SIGN(ONEONE,COSTH)
15414 IF (REDU.LT.1.D+00) RETURN
15415 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15416 * IF(ABS(COSTH2).GT.0.9999999999999999D0)
15417 * &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15418 IF(ABS(COSTH2).GT.ONEONE)
15419 &COSTH2=SIGN(ONEONE,COSTH2)
15420 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15421 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15422 SINTH1=COSTH2*SINTH-COSTH*SINTH2
15423 COSTH1=COSTH*COSTH2+SINTH2*SINTH
15424 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15425 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15426 C***THE DIRECTION OF PARTICLE 3
15427 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15434 CALL DT_DSFECF(SIF3,COF3)
15435 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15436 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15438 COD1=CX11*COD3+CZ11*SID3
15439 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15440 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15443 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15444 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15445 COD2=CX22*COD3+CZ22*SID3
15446 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15447 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15448 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15450 * === Energy conservation check: === *
15451 EOCHCK = UMO - ECM1 - ECM2 - ECM3
15452 * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15453 * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15454 * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15455 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15456 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15457 & + PCM3 * COF3 * SID3
15458 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15459 & + PCM3 * SIF3 * SID3
15460 EOCMPR = 1.D-12 * UMO
15461 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15462 & .GT. EOCMPR ) THEN
15463 **sr 5.5.95 output-unit changed
15464 IF (IOULEV(1).GT.0) THEN
15466 & ' *** Threpd: energy/momentum conservation failure! ***',
15467 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
15468 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15475 *$ CREATE DT_DBKLAS.FOR
15478 *===dbklas=============================================================*
15480 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15482 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15484 PARAMETER ( LINP = 10 ,
15488 * quark-content to particle index conversion (DTUNUC 1.x)
15489 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15490 & IA08(6,21),IA10(6,21)
15495 CALL DT_INDEXD(J,K,IND)
15498 IF (I8.LE.0) I8 = I10
15505 CALL DT_INDEXD(JJ,KK,IND)
15508 IF (I8.LE.0) I8 = I10
15513 *$ CREATE DT_INDEXD.FOR
15516 *===indexd=============================================================*
15518 SUBROUTINE DT_INDEXD(KA,KB,IND)
15520 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15522 PARAMETER ( LINP = 10 ,
15531 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15533 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15534 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15535 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15537 IF (KP.EQ.10) IND=10
15538 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15539 IF (KP.EQ.9) IND=12
15540 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15541 IF (KP.EQ.15) IND=14
15542 IF (KP.EQ.18) IND=15
15543 IF (KP.EQ.16) IND=16
15544 IF (KP.EQ.20) IND=17
15545 IF (KP.EQ.24) IND=18
15546 IF (KP.EQ.25) IND=19
15547 IF (KP.EQ.30) IND=20
15548 IF (KP.EQ.36) IND=21
15553 *$ CREATE DT_DCHANT.FOR
15556 *===dchant=============================================================*
15558 SUBROUTINE DT_DCHANT
15560 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15562 PARAMETER ( LINP = 10 ,
15565 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15567 * HADRIN: decay channel information
15568 PARAMETER (IDMAX9=602)
15570 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15571 * particle properties (BAMJET index convention)
15573 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15574 & IICH(210),IIBAR(210),K1(210),K2(210)
15576 DIMENSION HWT(IDMAX9)
15578 * change of weights wt from absolut values into the sum of wt of a dec.
15583 C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15584 C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15585 C & K1(KKK),K2(KKK)
15596 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15597 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15607 *$ CREATE DT_DDATAR.FOR
15610 *===ddatar=============================================================*
15612 SUBROUTINE DT_DDATAR
15614 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15616 PARAMETER ( LINP = 10 ,
15619 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15621 * quark-content to particle index conversion (DTUNUC 1.x)
15622 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15623 & IA08(6,21),IA10(6,21)
15625 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15627 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
15628 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
15630 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
15631 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
15633 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
15634 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
15635 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
15636 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
15637 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
15638 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
15639 & 0, 0, 0,140,137,138,146, 0, 0,142,
15640 & 139,147, 0, 0,145,148, 50*0/
15641 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
15642 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
15643 & 0, 54, 55,105,162, 0, 0, 56,106,163,
15644 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
15645 & 0, 0,104,105,107,164, 0, 0,106,108,
15646 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
15647 & 0, 0, 0,161,162,164,167, 0, 0,163,
15648 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
15649 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
15650 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
15651 & 0, 2, 9,100,149, 0, 0, 0,101,154,
15652 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
15653 & 0, 0, 99,100,102,150, 0, 0,101,103,
15654 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
15655 & 0, 0, 0,152,149,150,158, 0, 0,154,
15656 & 151,159, 0, 0,157,160, 50*0/
15657 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
15658 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
15659 & 0, 68, 69,111,172, 0, 0, 70,112,173,
15660 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
15661 & 0, 0,110,111,113,174, 0, 0,112,114,
15662 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
15663 & 0, 0, 0,171,172,174,177, 0, 0,173,
15664 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
15700 *$ CREATE DT_INITJS.FOR
15703 *===initjs=============================================================*
15705 SUBROUTINE DT_INITJS(MODE)
15707 ************************************************************************
15708 * Initialize JETSET paramters. *
15709 * MODE = 0 default settings *
15710 * = 1 PHOJET settings *
15711 * = 2 DTUNUC settings *
15712 * This version dated 16.02.96 is written by S. Roesler *
15714 * Last change 27.12.2006 by S. Roesler. *
15715 ************************************************************************
15717 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15719 PARAMETER ( LINP = 10 ,
15722 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15724 LOGICAL LFIRST,LFIRDT,LFIRPH
15726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15727 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15728 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15729 * flags for particle decays
15730 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15731 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15732 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15733 * flags for input different options
15734 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15735 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15736 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15740 DIMENSION IDXSTA(40)
15742 * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
15743 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15744 * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
15745 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
15746 * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15747 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15748 * Ksic0 aKsic+aKsic0 sig0 asig0
15749 & 4132,-4232,-4132, 3212,-3212, 5*0/
15751 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15754 * save default settings
15766 * LUJETS / PYJETS array-dimensions
15768 * increase maximum number of JETSET-error prints
15770 * prevent particles decaying
15773 KC = PYCOMP(IDXSTA(I))
15780 C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15781 C & (I.EQ.8).OR.(I.EQ.10)) THEN
15782 C ELSEIF (I.EQ.4) THEN
15786 C AM MDCY(KC,1) = 0
15789 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15790 KC = PYCOMP(IDXSTA(I))
15792 C AM MDCY(KC,1) = 0
15799 IF (PDB.LE.ZERO) THEN
15800 * no popcorn-mechanism
15806 * set JETSET-parameter requested by input cards
15807 IF (NMSTU.GT.0) THEN
15809 MSTU(IMSTU(I)) = MSTUX(I)
15812 IF (NMSTJ.GT.0) THEN
15814 MSTJ(IMSTJ(I)) = MSTJX(I)
15817 IF (NPARU.GT.0) THEN
15819 PARU(IPARU(I)) = PARUX(I)
15825 * PARJ(1) suppression of qq-aqaq pair prod. compared to
15826 * q-aq pair prod. (default: 0.1)
15827 * PARJ(2) strangeness suppression (default: 0.3)
15828 * PARJ(3) extra suppression of strange diquarks (default: 0.4)
15829 * PARJ(6) extra suppression of sas-pair shared by B and
15830 * aB in BMaB (default: 0.5)
15831 * PARJ(7) extra suppression of strange meson M in BMaB
15832 * configuration (default: 0.5)
15833 * PARJ(18) spin 3/2 baryon suppression (default: 1.0)
15834 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15835 * momentum distrib. for prim. hadrons (default: 0.35)
15836 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15837 * function (default: 0.9 GeV^-2)
15840 IF (MODE.EQ.1) THEN
15847 C PARJ(18) = PDEF18
15848 C PARJ(21) = PDEF21
15849 C PARJ(42) = PDEF42
15850 **sr 18.11.98 parameter tuning
15851 C PARJ(1) = 0.092D0
15855 C PARJ(21) = 0.45D0
15857 **sr 28.04.99 parameter tuning (May 99 minor modifications)
15867 IF (NPARJ.GT.0) THEN
15869 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15873 WRITE(LOUT,'(1X,A)')
15874 & 'DT_INITJS: JETSET-parameter for PHOJET'
15879 ELSEIF (MODE.EQ.2) THEN
15880 IF (IFRAG(2).EQ.1) THEN
15881 **sr parameters before 9.3.96
15886 C PARJ(21) = 0.55D0
15888 **sr 18.11.98 parameter tuning
15893 C PARJ(21) = 0.45D0
15895 **sr 28.04.99 parameter tuning
15903 IF (NPARJ.GT.0) THEN
15905 IF (IPARJ(I).LT.0) THEN
15906 IDX = ABS(IPARJ(I))
15907 PARJ(IDX) = PARJX(I)
15912 WRITE(LOUT,'(1X,A)')
15913 & 'DT_INITJS: JETSET-parameter for DTUNUC'
15917 ELSEIF (IFRAG(2).EQ.2) THEN
15924 C PARJ(21) = 0.55D0
15955 *$ CREATE DT_JSPARA.FOR
15958 *===jspara=============================================================*
15960 SUBROUTINE DT_JSPARA(MODE)
15962 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15964 PARAMETER ( LINP = 10 ,
15967 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15968 & ONE=1.0D0,ZERO=0.0D0)
15972 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15974 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15976 DATA LFIRST /.TRUE./
15978 * save the default JETSET-parameter on the first call
15990 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
15992 * compare the default JETSET-parameter with the present values
15994 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
15995 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
15996 C ISTU(I) = MSTU(I)
15998 DIFF = ABS(PARU(I)-QARU(I))
15999 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16000 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16001 C QARU(I) = PARU(I)
16003 IF (MSTJ(I).NE.ISTJ(I)) THEN
16004 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16005 C ISTJ(I) = MSTJ(I)
16007 DIFF = ABS(PARJ(I)-QARJ(I))
16008 IF (DIFF.GE.1.0D-5) THEN
16009 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16010 C QARJ(I) = PARJ(I)
16013 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16014 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16019 *$ CREATE DT_FOZOCA.FOR
16022 *===fozoca=============================================================*
16024 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16026 ************************************************************************
16027 * This subroutine treats the complete FOrmation ZOne supressed intra- *
16028 * nuclear CAscade. *
16029 * LFZC = .true. cascade has been treated *
16030 * = .false. cascade skipped *
16031 * This is a completely revised version of the original FOZOKL. *
16032 * This version dated 18.11.95 is written by S. Roesler *
16033 ************************************************************************
16035 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16037 PARAMETER ( LINP = 10 ,
16040 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16041 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16043 LOGICAL LSTART,LCAS,LFZC
16046 PARAMETER (NMXHKK=200000)
16047 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16048 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16049 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16050 * extended event history
16051 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16052 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16054 * rejection counter
16055 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16056 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16057 & IREXCI(3),IRDIFF(2),IRINC
16058 * properties of interacting particles
16059 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16060 * Glauber formalism: collision properties
16061 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16062 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16063 * flags for input different options
16064 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16065 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16066 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16067 * final state after intranuclear cascade step
16068 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16069 * parameter for intranuclear cascade
16071 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16073 DIMENSION NCWOUN(2)
16075 DATA LSTART /.TRUE./
16080 * skip cascade if hadron-hadron interaction or if supressed by user
16081 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16082 * skip cascade if not all possible chains systems are hadronized
16084 IF (.NOT.LHADRO(I)) GOTO 9999
16088 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16089 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16090 & 'maximum of',I4,' generations',/,10X,'formation time ',
16091 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16092 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16093 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16094 1001 FORMAT(10X,'p_t dependent formation zone',/)
16095 1002 FORMAT(10X,'constant formation zone',/)
16099 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16100 * which may interact with final state particles are stored in a seperate
16101 * array - here all proj./target nucleon-indices (just for simplicity)
16103 DO 9 I=1,NPOINT(1)-1
16108 * initialize Pauli-principle treatment (find wounded nucleons)
16115 IF (ISTHKK(J).EQ.10+I) THEN
16116 NWOUND(I) = NWOUND(I)+1
16117 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16118 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16123 * modify nuclear potential for wounded nucleons
16124 IPRCL = IP -NWOUND(1)
16125 IPZRCL = IPZ-NCWOUN(1)
16126 ITRCL = IT -NWOUND(2)
16127 ITZRCL = ITZ-NCWOUN(2)
16128 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16136 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16137 * select nucleus the cascade starts first (proj. - 1, target - -1)
16139 * projectile/target with probab. 1/2
16140 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16141 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16142 * in the nucleus with highest mass
16143 ELSEIF (INCMOD.EQ.2) THEN
16146 ELSEIF (IP.EQ.IT) THEN
16147 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16149 * the nucleus the cascade starts first is requested to be the one
16150 * moving in the direction of the secondary
16151 ELSEIF (INCMOD.EQ.3) THEN
16152 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16154 * check that the selected "nucleus" is not a hadron
16155 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16156 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
16158 * treat intranuclear cascade in the nucleus selected first
16160 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16161 IF (IREJ1.NE.0) GOTO 9998
16162 * treat intranuclear cascade in the other nucleus if this isn't a had.
16164 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16165 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
16166 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16167 IF (IREJ1.NE.0) GOTO 9998
16175 IF (NSTART.LE.NEND) GOTO 7
16180 * reject this event
16185 * intranucl. cascade not treated because of interaction properties or
16186 * it is supressed by user or it was rejected or...
16188 * reset flag characterizing direction of motion in n-n-cms
16190 C DO 9990 I=NPOINT(5),NHKK
16191 C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16197 *$ CREATE DT_INUCAS.FOR
16200 *===inucas=============================================================*
16202 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16204 ************************************************************************
16205 * Formation zone supressed IntraNUclear CAScade for one final state *
16207 * IT, IP mass numbers of target, projectile nuclei *
16208 * IDXCAS index of final state particle in DTEVT1 *
16209 * NCAS = 1 intranuclear cascade in projectile *
16210 * = -1 intranuclear cascade in target *
16211 * This version dated 18.11.95 is written by S. Roesler *
16212 ************************************************************************
16214 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16216 PARAMETER ( LINP = 10 ,
16220 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16221 & OHALF=0.5D0,ONE=1.0D0)
16222 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16223 PARAMETER (TWOPI=6.283185307179586454D+00)
16224 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16226 LOGICAL LABSOR,LCAS
16229 PARAMETER (NMXHKK=200000)
16230 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16231 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16232 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16233 * extended event history
16234 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16235 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16237 * final state after inc step
16238 PARAMETER (MAXFSP=10)
16239 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16240 * flags for input different options
16241 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16242 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16243 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16244 * particle properties (BAMJET index convention)
16246 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16247 & IICH(210),IIBAR(210),K1(210),K2(210)
16248 * Glauber formalism: collision properties
16249 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16250 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16251 * nuclear potential
16253 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16254 & EBINDP(2),EBINDN(2),EPOT(2,210),
16255 & ETACOU(2),ICOUL,LFERMI
16256 * parameter for intranuclear cascade
16258 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16259 * final state after intranuclear cascade step
16260 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16261 * nucleon-nucleon event-generator
16264 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16265 * statistics: residual nuclei
16266 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16267 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16268 & NINCST(2,4),NINCEV(2),
16269 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16270 & NRESPB(2),NRESCH(2),NRESEV(4),
16271 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16274 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16275 & PCAS1(5),PNUC(5),BGTA(4),
16276 & BGCAS(2),GACAS(2),BECAS(2),
16277 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16279 DATA PDIF /0.545D0/
16284 IF (NINCEV(1).NE.NEVHKK) THEN
16286 NINCEV(2) = NINCEV(2)+1
16289 * "BAMJET-index" of this hadron
16290 IDCAS = IDBAM(IDXCAS)
16291 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16293 * skip gammas, electrons, etc..
16294 IF (AAM(IDCAS).LT.TINY2) RETURN
16296 * Lorentz-trsf. into projectile rest system
16298 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16299 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16300 & PCAS(1,4),IDCAS,-2)
16301 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16302 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16303 IF (PCAS(1,5).GT.ZERO) THEN
16304 PCAS(1,5) = SQRT(PCAS(1,5))
16306 PCAS(1,5) = AAM(IDCAS)
16309 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16311 * Lorentz-parameters
16312 * particle rest system --> projectile rest system
16313 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16314 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16315 BECAS(1) = BGCAS(1)/GACAS(1)
16319 IF (K.LE.3) COSCAS(1,K) = ZERO
16326 * Lorentz-trsf. into target rest system
16328 * LEPTO: final state particles are already in target rest frame
16329 C IF (MCGENE.EQ.3) THEN
16330 C PCAS(2,1) = PHKK(1,IDXCAS)
16331 C PCAS(2,2) = PHKK(2,IDXCAS)
16332 C PCAS(2,3) = PHKK(3,IDXCAS)
16333 C PCAS(2,4) = PHKK(4,IDXCAS)
16335 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16336 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16337 & PCAS(2,4),IDCAS,-3)
16339 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16340 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16341 IF (PCAS(2,5).GT.ZERO) THEN
16342 PCAS(2,5) = SQRT(PCAS(2,5))
16344 PCAS(2,5) = AAM(IDCAS)
16347 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16349 * Lorentz-parameters
16350 * particle rest system --> target rest system
16351 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16352 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16353 BECAS(2) = BGCAS(2)/GACAS(2)
16357 IF (K.LE.3) COSCAS(2,K) = ZERO
16365 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16366 * potential (see CONUCL)
16367 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
16368 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
16369 * impact parameter (the projectile moving along z)
16371 BIMPC(2) = BIMPAC*FM2MM
16373 * get position of initial hadron in projectile/target rest-syst.
16375 VTXCAS(1,K) = WHKK(K,IDXCAS)
16376 VTXCAS(2,K) = VHKK(K,IDXCAS)
16381 IF (NCAS.EQ.-1) THEN
16386 IF (PTOCAS(ICAS).LT.TINY10) THEN
16387 WRITE(LOUT,1000) PTOCAS
16388 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
16389 & ' hadron ',/,20X,2E12.4)
16393 * reset spectator flags
16400 * formation length (in fm)
16404 DEL0 = TAUFOR*BGCAS(ICAS)
16405 IF (ITAUVE.EQ.1) THEN
16406 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16407 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16410 * sample from exp(-del/del0)
16411 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16412 * save formation time
16413 TAUSA1 = DEL1/BGCAS(ICAS)
16414 REL1 = TAUSA1*BGCAS(I2)
16417 TAUSAM = DEL/BGCAS(ICAS)
16418 REL = TAUSAM*BGCAS(I2)
16420 * special treatment for negative particles unable to escape
16421 * nuclear potential (implemented for ap, pi-, K- only)
16423 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16424 * threshold energy = nuclear potential + Coulomb potential
16425 * (nuclear potential for hadron-nucleus interactions only)
16426 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16427 IF (PCAS(ICAS,4).LT.ETHR) THEN
16429 PCAS1(K) = PCAS(ICAS,K)
16431 * "absorb" negative particle in nucleus
16432 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16433 IF (IREJ1.NE.0) GOTO 9999
16434 IF (NSPE.GE.1) LABSOR = .TRUE.
16438 * if the initial particle has not been absorbed proceed with
16440 IF (.NOT.LABSOR) THEN
16442 * calculate coordinates of hadron at the end of the formation zone
16443 * transport-time and -step in the rest system where this step is
16446 DTIME = DSTEP/BECAS(ICAS)
16448 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16449 RTIME = RSTEP/BECAS(I2)
16453 * save step whithout considering the overlapping region
16454 DSTEP1 = DEL1*FM2MM
16455 DTIME1 = DSTEP1/BECAS(ICAS)
16456 RSTEP1 = REL1*FM2MM
16457 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16458 RTIME1 = RSTEP1/BECAS(I2)
16462 * transport to the end of the formation zone in this system
16464 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16465 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
16466 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16467 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
16469 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16470 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
16471 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16472 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
16474 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16475 XCAS = VTXCAS(ICAS,1)
16476 YCAS = VTXCAS(ICAS,2)
16477 XNCLTA = BIMPAC*FM2MM
16478 RNCLPR = (RPROJ+RNUCLE)*FM2MM
16479 RNCLTA = (RTARG+RNUCLE)*FM2MM
16480 C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16481 C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16482 C RNCLPR = (RPROJ)*FM2MM
16483 C RNCLTA = (RTARG)*FM2MM
16484 RCASPR = SQRT( XCAS**2 +YCAS**2)
16485 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16486 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16487 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16491 * check if particle is already outside of the corresp. nucleus
16492 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16493 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16494 IF (RDIST.GE.RNUC(ICAS)) THEN
16495 * here: IDCH is the generation of the final state part. starting
16496 * with zero for hadronization products
16497 * flag particles of generation 0 being outside the nuclei after
16498 * formation time (to be used for excitation energy calculation)
16499 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16500 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16509 * already here: skip particles being outside HADRIN "energy-window"
16510 * to avoid wasting of time
16511 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16512 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16513 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16514 C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16515 C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
16516 C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16517 C & E12.4,', above or below HADRIN-thresholds',I6)
16522 DO 7 IDXHKK=1,NOINC
16524 * scan DTEVT1 for unwounded or excited nucleons
16525 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16527 IF (ICAS.EQ.1) THEN
16528 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16529 ELSEIF (ICAS.EQ.2) THEN
16530 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16533 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16534 & VTXDST(2)*COSCAS(ICAS,2)+
16535 & VTXDST(3)*COSCAS(ICAS,3)
16536 * check if nucleon is situated in forward direction
16537 IF (POSNUC.GT.ZERO) THEN
16538 * distance between hadron and this nucleon
16539 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16542 BIMNU2 = DISTNU**2-POSNUC**2
16543 IF (BIMNU2.LT.ZERO) THEN
16544 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16545 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
16546 & ' parameter ',/,20X,3E12.4)
16549 BIMNU = SQRT(BIMNU2)
16550 * maximum impact parameter to have interaction
16551 IDNUC = IDT_ICIHAD(IDHKK(I))
16552 IDNUC1 = IDT_MCHAD(IDNUC)
16553 IDCAS1 = IDT_MCHAD(IDCAS)
16555 PCAS1(K) = PCAS(ICAS,K)
16556 PNUC(K) = PHKK(K,I)
16558 * Lorentz-parameter for trafo into rest-system of target
16560 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16562 * transformation of projectile into rest-system of target
16563 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16564 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16565 & PPTOT,PX,PY,PZ,PE)
16567 C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16568 C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16570 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16571 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16572 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16573 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16574 SIGIN = SIGTOT-SIGEL-SIGAB
16575 C SIGTOT = SIGIN+SIGEL+SIGAB
16577 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16578 * check if interaction is possible
16579 IF (BIMNU.LE.BIMMAX) THEN
16580 * get nucleon with smallest distance and kind of interaction
16581 * (elastic/inelastic)
16582 IF (DISTNU.LT.DIST) THEN
16585 IF (IDNUC.NE.IDSPE(1)) THEN
16586 IDSPE(2) = IDSPE(1)
16587 IDXSPE(2) = IDXSPE(1)
16596 C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16598 C STOT = SIGIN+SIGEL
16600 C SELA = SIGEL+0.75D0*SIGIN
16601 C STOT = 0.25D0*SIGIN+SELA
16607 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16609 IDNUC = IDT_ICIHAD(IDHKK(I))
16610 IF (IDNUC.EQ.1) THEN
16611 IF (DISTNU.LT.DISTP) THEN
16616 ELSEIF (IDNUC.EQ.8) THEN
16617 IF (DISTNU.LT.DISTN) THEN
16626 * there is no nucleon for a secondary interaction
16627 IF (NSPE.EQ.0) GOTO 9997
16629 C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16630 C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16631 IF (IDXSPE(2).EQ.0) THEN
16632 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16634 C IF (ICAS.EQ.1) THEN
16635 C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16636 C ELSEIF (ICAS.EQ.2) THEN
16637 C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16640 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16642 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16649 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16651 C IF (ICAS.EQ.1) THEN
16652 C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16653 C ELSEIF (ICAS.EQ.2) THEN
16654 C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16657 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16659 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16672 IF (RR.LT.SELA/STOT) THEN
16674 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16681 PCAS1(K) = PCAS(ICAS,K)
16682 PNUC(K) = PHKK(K,IDXSPE(1))
16684 IF (IPROC.EQ.3) THEN
16685 * 2-nucleon absorption of pion
16687 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16688 IF (IREJ1.NE.0) GOTO 9999
16689 IF (NSPE.GE.1) LABSOR = .TRUE.
16691 * sample secondary interaction
16692 IDNUC = IDBAM(IDXSPE(1))
16693 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16694 IF (IREJ1.EQ.1) GOTO 9999
16695 IF (IREJ1.GT.1) GOTO 9998
16699 * update arrays to include Pauli-principle
16701 IF (NWOUND(ICAS).LE.299) THEN
16702 NWOUND(ICAS) = NWOUND(ICAS)+1
16703 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16707 * dump initial hadron for energy-momentum conservation check
16709 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16710 & PCAS(ICAS,4),1,IDUM,IDUM)
16712 * dump final state particles into DTEVT1
16714 * check if Pauli-principle is fulfilled
16716 NWTMP(1) = NWOUND(1)
16717 NWTMP(2) = NWOUND(2)
16721 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16722 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16724 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16731 IF (IDX.EQ.1) MODE = -1
16732 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16734 * first check if cascade step is forbidden due to Pauli-principle
16735 * (in case of absorpion this step is forced)
16736 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16737 & (IDFSP(I).EQ.8))) THEN
16738 * get nuclear potential barrier
16739 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16740 IF (IDFSP(I).EQ.1) THEN
16741 POTLOW = POT-EBINDP(IDX)
16743 POTLOW = POT-EBINDN(IDX)
16745 * final state particle not able to escape nucleus
16746 IF (PE.LE.POTLOW) THEN
16747 * check if there are wounded nucleons
16748 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16749 & EWOUND(IDX,NWOUND(IDX)))) THEN
16751 NWOUND(IDX) = NWOUND(IDX)-1
16753 * interaction prohibited by Pauli-principle
16754 NWOUND(1) = NWTMP(1)
16755 NWOUND(2) = NWTMP(2)
16764 NWOUND(1) = NWTMP(1)
16765 NWOUND(2) = NWTMP(2)
16769 IST = ISTHKK(IDXCAS)
16773 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16774 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16776 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16781 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16783 * first check if cascade step is forbidden due to Pauli-principle
16784 * (in case of absorpion this step is forced)
16785 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16786 & (IDFSP(I).EQ.8))) THEN
16787 * get nuclear potential barrier
16788 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16789 IF (IDFSP(I).EQ.1) THEN
16790 POTLOW = POT-EBINDP(IDX)
16792 POTLOW = POT-EBINDN(IDX)
16794 * final state particle not able to escape nucleus
16795 IF (PE.LE.POTLOW) THEN
16796 * check if there are wounded nucleons
16797 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16798 & EWOUND(IDX,NWOUND(IDX)))) THEN
16799 NWOUND(IDX) = NWOUND(IDX)-1
16803 * interaction prohibited by Pauli-principle
16804 NWOUND(1) = NWTMP(1)
16805 NWOUND(2) = NWTMP(2)
16809 c ELSEIF (PE.LE.POT) THEN
16810 cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16811 cC NWOUND(IDX) = NWOUND(IDX)-1
16813 c NPAULI = NPAULI+1
16819 * dump final state particles for energy-momentum conservation check
16820 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16821 & -PFSP(4,I),2,IDUM,IDUM)
16827 IF (ABS(IST).EQ.1) THEN
16828 * transform particles back into n-n cms
16829 * LEPTO: leave final state particles in target rest frame
16830 C IF (MCGENE.EQ.3) THEN
16837 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16838 & PFSP(4,I),IDFSP(I),IMODE)
16840 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16841 * target cascade but fsp got stuck in proj. --> transform it into
16842 * proj. rest system
16843 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16844 & PFSP(4,I),IDFSP(I),-1)
16845 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16846 * proj. cascade but fsp got stuck in target --> transform it into
16847 * target rest system
16848 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16849 & PFSP(4,I),IDFSP(I),1)
16852 * dump final state particles into DTEVT1
16853 IGEN = IDCH(IDXCAS)+1
16854 ID = IDT_IPDGHA(IDFSP(I))
16856 IF (LABSOR) IXR = 99
16857 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16858 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16860 * update the counter for particles which got stuck inside the nucleus
16861 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16863 IDXINC(NOINC) = NHKK
16866 * in case of absorption the spatial treatment is an approximate
16867 * solution anyway (the positions of the nucleons which "absorb" the
16868 * cascade particle are not taken into consideration) therefore the
16869 * particles are produced at the position of the cascade particle
16871 WHKK(K,NHKK) = WHKK(K,IDXCAS)
16872 VHKK(K,NHKK) = VHKK(K,IDXCAS)
16875 * DDISTL - distance the cascade particle moves to the intera. point
16876 * (the position where impact-parameter = distance to the interacting
16877 * nucleon), DIST - distance to the interacting nucleon at the time of
16878 * formation of the cascade particle, BINT - impact-parameter of this
16879 * cascade-interaction
16880 DDISTL = SQRT(DIST**2-BINT**2)
16881 DTIME = DDISTL/BECAS(ICAS)
16882 DTIMEL = DDISTL/BGCAS(ICAS)
16883 RDISTL = DTIMEL*BGCAS(I2)
16884 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16885 RTIME = RDISTL/BECAS(I2)
16889 * RDISTL, RTIME are this step and time in the rest system of the other
16892 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16893 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
16895 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16896 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
16897 * position of particle production is half the impact-parameter to
16898 * the interacting nucleon
16900 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16901 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16903 * time of production of secondary = time of interaction
16904 WHKK(4,NHKK) = VTXCA1(1,4)
16905 VHKK(4,NHKK) = VTXCA1(2,4)
16910 * modify status and position of cascade particle (the latter for
16911 * statistics reasons only)
16913 IF (LABSOR) ISTHKK(IDXCAS) = 19
16914 IF (.NOT.LABSOR) THEN
16916 WHKK(K,IDXCAS) = VTXCA1(1,K)
16917 VHKK(K,IDXCAS) = VTXCA1(2,K)
16923 * dump interacting nucleons for energy-momentum conservation check
16925 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16927 * modify entry for interacting nucleons
16928 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16929 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16931 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16932 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16936 * check energy-momentum conservation
16938 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16939 IF (IREJ1.NE.0) GOTO 9999
16944 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16946 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16947 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16954 * transport-step but no cascade step due to configuration (i.e. there
16955 * is no nucleon for interaction etc.)
16958 C WHKK(K,IDXCAS) = VTXCAS(1,K)
16959 C VHKK(K,IDXCAS) = VTXCAS(2,K)
16960 WHKK(K,IDXCAS) = VTXCA1(1,K)
16961 VHKK(K,IDXCAS) = VTXCA1(2,K)
16966 * no cascade-step because of configuration
16967 * (i.e. hadron outside nucleus etc.)
16977 *$ CREATE DT_ABSORP.FOR
16980 *===absorp=============================================================*
16982 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16984 ************************************************************************
16985 * Two-nucleon absorption of antiprotons, pi-, and K-. *
16986 * Antiproton absorption is handled by HADRIN. *
16987 * The following channels for meson-absorption are considered: *
16988 * pi- + p + p ---> n + p *
16989 * pi- + p + n ---> n + n *
16990 * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
16991 * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
16992 * K- + p + p ---> sigma- + n *
16993 * IDCAS, PCAS identity, momentum of particle to be absorbed *
16994 * NCAS = 1 intranuclear cascade in projectile *
16995 * = -1 intranuclear cascade in target *
16996 * NSPE number of spectator nucleons involved *
16997 * IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
16998 * Revised version of the original STOPIK written by HJM and J. Ranft. *
16999 * This version dated 24.02.95 is written by S. Roesler *
17000 ************************************************************************
17002 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17004 PARAMETER ( LINP = 10 ,
17007 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17008 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17011 PARAMETER (NMXHKK=200000)
17012 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17013 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17014 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17015 * extended event history
17016 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17017 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17019 * flags for input different options
17020 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17021 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17022 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17023 * final state after inc step
17024 PARAMETER (MAXFSP=10)
17025 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17026 * particle properties (BAMJET index convention)
17028 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17029 & IICH(210),IIBAR(210),K1(210),K2(210)
17031 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17032 & PTOT3P(4),BG3P(4),
17033 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17038 * skip particles others than ap, pi-, K- for mode=0
17039 IF ((MODE.EQ.0).AND.
17040 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17041 * skip particles others than pions for mode=1
17042 * (2-nucleon absorption in intranuclear cascade)
17043 IF ((MODE.EQ.1).AND.
17044 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17047 IF (NUCAS.EQ.-1) NUCAS = 2
17049 IF (MODE.EQ.0) THEN
17050 * scan spectator nucleons for nucleons being able to "absorb"
17055 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17058 IDSPE(NSPE) = IDBAM(I)
17059 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17060 IF (NSPE.EQ.2) THEN
17061 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17062 & (IDSPE(2).EQ.8)) THEN
17063 * there is no pi-+n+n channel
17075 * transform excited projectile nucleons (status=15) into proj. rest s.
17078 PSPE(I,K) = PHKK(K,IDXSPE(I))
17082 * antiproton absorption
17083 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17085 PSPE1(K) = PSPE(1,K)
17087 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17088 IF (IREJ1.NE.0) GOTO 9999
17091 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17092 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17093 IF (IDCAS.EQ.14) THEN
17097 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17098 ELSEIF (IDCAS.EQ.13) THEN
17102 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17103 ELSEIF (IDCAS.EQ.23) THEN
17105 IDFSP(1) = IDSPE(1)
17106 IDFSP(2) = IDSPE(2)
17107 ELSEIF (IDCAS.EQ.16) THEN
17110 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17111 IF (R.LT.ONETHI) THEN
17114 ELSEIF (R.LT.TWOTHI) THEN
17121 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17125 IF (R.LT.ONETHI) THEN
17128 ELSEIF (R.LT.TWOTHI) THEN
17137 * dump initial particles for energy-momentum cons. check
17139 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17140 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17142 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17145 * get Lorentz-parameter of 3 particle initial state
17147 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17149 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17150 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17152 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17154 * 2-particle decay of the 3-particle compound system
17155 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17156 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17157 & AAM(IDFSP(1)),AAM(IDFSP(2)))
17159 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17160 PX = PCMF(I)*COFF(I)*SDF
17161 PY = PCMF(I)*SIFF(I)*SDF
17162 PZ = PCMF(I)*CODF(I)
17163 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17164 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17166 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17167 * check consistency of kinematics
17168 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17169 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17170 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
17171 & ' tree-particle kinematics',/,20X,'id: ',I3,
17172 & ' AAM = ',E10.4,' MFSP = ',E10.4)
17174 * dump final state particles for energy-momentum cons. check
17175 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17176 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17180 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17181 IF (IREJ1.NE.0) THEN
17182 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17188 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17189 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
17190 & ' impossible',/,20X,'too few spectators (',I2,')')
17197 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17202 *$ CREATE DT_HADRIN.FOR
17205 *===hadrin=============================================================*
17207 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17209 ************************************************************************
17210 * Interface to the HADRIN-routines for inelastic and elastic *
17212 * IDPR,PPR(5) identity, momentum of projectile *
17213 * IDTA,PTA(5) identity, momentum of target *
17214 * MODE = 1 inelastic interaction *
17215 * = 2 elastic interaction *
17216 * Revised version of the original FHAD. *
17217 * This version dated 27.10.95 is written by S. Roesler *
17218 ************************************************************************
17220 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17222 PARAMETER ( LINP = 10 ,
17225 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17226 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17228 LOGICAL LCORR,LMSSG
17230 * flags for input different options
17231 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17232 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17233 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17234 * final state after inc step
17235 PARAMETER (MAXFSP=10)
17236 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17237 * particle properties (BAMJET index convention)
17239 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17240 & IICH(210),IIBAR(210),K1(210),K2(210)
17241 * output-common for DHADRI/ELHAIN
17242 * final state from HADRIN interaction
17243 PARAMETER (MAXFIN=10)
17244 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17245 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17247 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17248 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17250 DATA LMSSG /.TRUE./
17259 * dump initial particles for energy-momentum cons. check
17261 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17262 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17265 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17266 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17267 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17268 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17269 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17270 IF (LMSSG.AND.(IOULEV(3).GT.0))
17271 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17272 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
17273 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17274 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17279 * convert initial state particles into particles which can be
17280 * handled by HADRIN
17283 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17284 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17291 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17292 IF (IREJ1.GT.0) THEN
17293 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17300 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17301 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17304 * Lorentz-parameter for trafo into rest-system of target
17306 BGTA(K) = PTA(K)/PTA(5)
17308 * transformation of projectile into rest-system of target
17309 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17310 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17313 * direction cosines of projectile in target rest system
17314 CX = PPR1(1)/PPRTO1
17315 CY = PPR1(2)/PPRTO1
17316 CZ = PPR1(3)/PPRTO1
17318 * sample inelastic interaction
17319 IF (MODE.EQ.1) THEN
17320 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17321 IF (IRH.EQ.1) GOTO 9998
17322 * sample elastic interaction
17323 ELSEIF (MODE.EQ.2) THEN
17324 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17325 IF (IREJ1.NE.0) THEN
17326 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17329 IF (IRH.EQ.1) GOTO 9998
17331 WRITE(LOUT,1001) MODE,INTHAD
17332 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
17333 & I4,' (INTHAD =',I4,')')
17337 * transform final state particles back into Lab.
17340 PX = CXRH(I)*PLRH(I)
17341 PY = CYRH(I)*PLRH(I)
17342 PZ = CZRH(I)*PLRH(I)
17343 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17344 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17345 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17346 IDFSP(NFSP) = ITRH(I)
17347 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17349 IF (AMFSP2.LT.-TINY3) THEN
17350 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17351 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17352 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
17353 & I2,') with negative mass^2',/,1X,5E12.4)
17356 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17357 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17358 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17360 1003 FORMAT(1X,'HADRIN: warning! final state particle',
17361 & ' (id = ',I2,') with inconsistent mass',/,1X,
17364 IF (KCORR.GT.2) GOTO 9999
17365 IMCORR(KCORR) = NFSP
17368 * dump final state particles for energy-momentum cons. check
17369 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17370 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17373 * transform momenta on mass shell in case of inconsistencies in
17375 IF (KCORR.GT.0) THEN
17376 IF (KCORR.EQ.2) THEN
17380 IF (IMCORR(1).EQ.1) THEN
17388 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17389 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17390 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17391 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17393 P1IN(K) = PFSP(K,I1)
17394 P2IN(K) = PFSP(K,I2)
17396 XM1 = AAM(IDFSP(I1))
17397 XM2 = AAM(IDFSP(I2))
17398 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17399 IF (IREJ1.GT.0) THEN
17400 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17404 PFSP(K,I1) = P1OUT(K)
17405 PFSP(K,I2) = P2OUT(K)
17407 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17408 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
17409 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17410 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
17411 * dump final state particles for energy-momentum cons. check
17412 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17413 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17414 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17415 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17418 * check energy-momentum conservation
17420 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17421 IF (IREJ1.NE.0) GOTO 9999
17435 *$ CREATE DT_HADCOL.FOR
17438 *===hadcol=============================================================*
17440 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17442 ************************************************************************
17443 * Interface to the HADRIN-routines for inelastic and elastic *
17444 * scattering. This subroutine samples hadron-nucleus interactions *
17445 * below DPM-threshold. *
17446 * IDPROJ BAMJET-index of projectile hadron *
17447 * PPN projectile momentum in target rest frame *
17448 * IDXTAR DTEVT1-index of target nucleon undergoing *
17449 * interaction with projectile hadron *
17450 * This subroutine replaces HADHAD. *
17451 * This version dated 5.5.95 is written by S. Roesler *
17452 ************************************************************************
17454 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17456 PARAMETER ( LINP = 10 ,
17459 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17464 PARAMETER (NMXHKK=200000)
17465 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17466 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17467 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17468 * extended event history
17469 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17470 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17472 * nuclear potential
17474 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17475 & EBINDP(2),EBINDN(2),EPOT(2,210),
17476 & ETACOU(2),ICOUL,LFERMI
17477 * interface HADRIN-DPM
17478 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17479 * parameter for intranuclear cascade
17481 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17482 * final state after inc step
17483 PARAMETER (MAXFSP=10)
17484 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17485 * particle properties (BAMJET index convention)
17487 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17488 & IICH(210),IIBAR(210),K1(210),K2(210)
17490 DIMENSION PPROJ(5),PNUC(5)
17492 DATA LSTART /.TRUE./
17499 **sr 6/9/01 commented
17500 C TAUFOR = TAUFOR/2.0D0
17504 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
17505 WRITE(LOUT,1001) TAUFOR
17506 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
17511 IDNUC = IDBAM(IDXTAR)
17512 IDNUC1 = IDT_MCHAD(IDNUC)
17513 IDPRO1 = IDT_MCHAD(IDPROJ)
17515 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17519 C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17520 C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17522 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17523 SIGIN = SIGTOT-SIGEL
17524 C SIGTOT = SIGIN+SIGEL
17527 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17533 PPROJ(5) = AAM(IDPROJ)
17534 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17536 PNUC(K) = PHKK(K,IDXTAR)
17542 IF (ILOOP.GT.100) GOTO 9999
17544 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17545 IF (IREJ1.EQ.1) GOTO 9999
17547 IF (IREJ1.GT.1) THEN
17548 * no interaction possible
17549 * require Pauli blocking
17550 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17551 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17552 IF ((IIBAR(IDPROJ).NE.1).AND.
17553 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
17554 * store incoming particle as final state particle
17555 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17556 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17559 * require Pauli blocking for final state nucleons
17561 IF ((IDFSP(I).EQ.1).AND.
17562 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
17563 IF ((IDFSP(I).EQ.8).AND.
17564 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
17565 IF ((IIBAR(IDFSP(I)).NE.1).AND.
17566 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17568 * store final state particles
17571 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17572 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17573 IDHAD = IDT_IPDGHA(IDFSP(I))
17574 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17575 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17577 IF (I.EQ.1) NPOINT(4) = NHKK
17578 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17579 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17580 VHKK(3,NHKK) = VHKK(3,IDXTAR)
17581 VHKK(4,NHKK) = VHKK(4,IDXTAR)
17582 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17583 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17584 WHKK(3,NHKK) = WHKK(3,1)
17585 WHKK(4,NHKK) = WHKK(4,1)
17597 *$ CREATE DT_GETEMU.FOR
17600 *===getemu=============================================================*
17602 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17604 ************************************************************************
17605 * Sampling of emulsion component to be considered as target-nucleus. *
17606 * This version dated 6.5.95 is written by S. Roesler. *
17607 ************************************************************************
17609 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17611 PARAMETER ( LINP = 10 ,
17614 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17616 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17617 * emulsion treatment
17618 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17620 * Glauber formalism: flags and parameters for statistics
17623 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17625 IF (MODE.EQ.0) THEN
17627 RR = DT_RNDM(SUMFRA)
17630 DO 1 ICOMP=1,NCOMPO
17631 SUMFRA = SUMFRA+EMUFRA(ICOMP)
17632 IF (SUMFRA.GT.RR) THEN
17634 ITZ = IEMUCH(ICOMP)
17641 WRITE(LOUT,'(1X,A,E12.3)')
17642 & 'Warning! norm. failure within emulsion fractions',
17646 ELSEIF (MODE.EQ.1) THEN
17649 IDIFF = ABS(IT-IEMUMA(I))
17650 IF (IDIFF.LT.NDIFF) THEN
17659 * bypass for variable projectile/target/energy runs: the correct
17660 * Glauber data will be always loaded on kkmat=1
17661 IF (IOGLB.EQ.100) THEN
17668 *$ CREATE DT_NCLPOT.FOR
17671 *===nclpot=============================================================*
17673 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17675 ************************************************************************
17676 * Calculation of Coulomb and nuclear potential for a given configurat. *
17677 * IPZ, IP charge/mass number of proj. *
17678 * ITZ, IT charge/mass number of targ. *
17679 * AFERP,AFERT factors modifying proj./target pot. *
17680 * if =0, FERMOD is used *
17681 * MODE = 0 calculation of binding energy *
17682 * = 1 pre-calculated binding energy is used *
17683 * This version dated 16.11.95 is written by S. Roesler. *
17685 * Last change 28.12.2006 by S. Roesler. *
17686 ************************************************************************
17688 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17690 PARAMETER ( LINP = 10 ,
17693 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17698 * particle properties (BAMJET index convention)
17700 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17701 & IICH(210),IIBAR(210),K1(210),K2(210)
17702 * nuclear potential
17704 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17705 & EBINDP(2),EBINDN(2),EPOT(2,210),
17706 & ETACOU(2),ICOUL,LFERMI
17708 DIMENSION IDXPOT(14)
17709 * ap an lam alam sig- sig+ sig0 tet0 tet- asig-
17710 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
17711 * asig0 asig+ atet0 atet+
17712 & 100, 101, 102, 103/
17715 DATA LSTART /.TRUE./
17717 IF (MODE.EQ.0) THEN
17729 IF (AFERP.LE.ZERO) FERMIP = FERMOD
17731 IF (AFERT.LE.ZERO) FERMIT = FERMOD
17733 * Fermi momenta and binding energy for projectile
17734 IF ((IP.GT.1).AND.LFERMI) THEN
17735 IF (MODE.EQ.0) THEN
17736 C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17737 C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17740 EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17741 & -DT_ENERGY(AIP,AIPZ))
17742 IF (AIP.LE.AIPZ) THEN
17743 EBINDN(1) = EBINDP(1)
17744 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17746 EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17747 & +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17750 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17751 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17756 * effective nuclear potential for projectile
17757 C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17758 C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17759 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17760 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17762 * Fermi momenta and binding energy for target
17763 IF ((IT.GT.1).AND.LFERMI) THEN
17764 IF (MODE.EQ.0) THEN
17765 C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17766 C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17770 EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17771 & -DT_ENERGY(AIT,AITZ))
17773 IF (AIT.LE.AITZ) THEN
17774 EBINDN(2) = EBINDP(2)
17775 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17778 EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17779 & +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17783 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17784 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17789 * effective nuclear potential for target
17790 C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17791 C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17792 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17793 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17796 EPOT(1,IDXPOT(I)) = EPOT(1,8)
17797 EPOT(2,IDXPOT(I)) = EPOT(2,8)
17803 IF (ICOUL.EQ.1) THEN
17805 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17807 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17811 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17812 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17813 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17815 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
17816 & ,' effects',/,12X,'---------------------------',
17817 & '----------------',/,/,38X,'projectile',
17818 & ' target',/,/,1X,'Mass number / charge',
17819 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
17820 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
17821 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
17822 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
17823 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
17824 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
17831 *$ CREATE DT_RESNCL.FOR
17834 *===resncl=============================================================*
17836 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17838 ************************************************************************
17839 * Treatment of residual nuclei and nuclear effects. *
17840 * MODE = 1 initializations *
17841 * = 2 treatment of final state *
17842 * This version dated 16.11.95 is written by S. Roesler. *
17844 * Last change 05.01.2007 by S. Roesler. *
17845 ************************************************************************
17847 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17849 PARAMETER ( LINP = 10 ,
17852 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17853 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17854 & ONETHI=ONE/THREE)
17855 PARAMETER (AMUAMU = 0.93149432D0,
17858 PARAMETER ( EMVGEV = 1.0 D-03 )
17859 PARAMETER ( AMUGEV = 0.93149432 D+00 )
17860 PARAMETER ( AMPRTN = 0.93827231 D+00 )
17861 PARAMETER ( AMNTRN = 0.93956563 D+00 )
17862 PARAMETER ( AMELCT = 0.51099906 D-03 )
17863 PARAMETER ( HLFHLF = 0.5D+00 )
17864 PARAMETER ( FERTHO = 14.33 D-09 )
17865 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17866 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17867 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17870 PARAMETER (NMXHKK=200000)
17871 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17872 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17873 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17874 * extended event history
17875 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17876 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17878 * particle properties (BAMJET index convention)
17880 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17881 & IICH(210),IIBAR(210),K1(210),K2(210)
17882 * flags for input different options
17883 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17884 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17885 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17886 * nuclear potential
17888 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17889 & EBINDP(2),EBINDN(2),EPOT(2,210),
17890 & ETACOU(2),ICOUL,LFERMI
17891 * properties of interacting particles
17892 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17893 * properties of photon/lepton projectiles
17894 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17895 * Lorentz-parameters of the current interaction
17896 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17897 & UMO,PPCM,EPROJ,PPROJ
17898 * treatment of residual nuclei: wounded nucleons
17899 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17900 * treatment of residual nuclei: 4-momenta
17901 LOGICAL LRCLPR,LRCLTA
17902 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17903 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17905 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17906 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17907 & IDXCOR(15000),IDXOTH(NMXHKK)
17911 *------- initializations
17914 * initialize arrays for residual nuclei
17929 * correction of projectile 4-momentum for effective target pot.
17930 * and Coulomb-energy (in case of hadron-nucleus interaction only)
17931 * IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17934 * positively charged hadron - check energy for Coloumb pot.
17935 * IF (IICH(IJPROJ).EQ.1) THEN
17936 * THRESH = ETACOU(2)+AAM(IJPROJ)
17937 * IF (EPNI.LE.THRESH) THEN
17939 * 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
17940 * & ' below Coulomb threshold - event rejected',/)
17944 * negatively charged hadron - increase energy by Coulomb energy
17945 * ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17946 * EPNI = EPNI+ETACOU(2)
17948 * IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
17949 * Effective target potential
17950 *sr 6.6. binding energy only (to avoid negative exc. energies)
17951 C EPNI = EPNI+EPOT(2,IJPROJ)
17952 * EBIPOT = EBINDP(2)
17953 * IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17954 * & EBIPOT = EBINDN(2)
17955 * EPNI = EPNI+ABS(EBIPOT)
17956 * re-initialization of DTLTRA
17960 * CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17964 * projectile in n-n cms
17965 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17966 PMASS1 = AAM(IJPROJ)
17968 C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17969 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17971 PM1 = SIGN(PMASS1**2,PMASS1)
17972 PM2 = SIGN(PMASS2**2,PMASS2)
17973 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17975 IF (PMASS1.GT.ZERO) THEN
17976 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17977 & *(PINIPR(4)+PINIPR(5)))
17979 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17983 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17984 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17985 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17987 PMASS2 = AAM(IJTARG)
17988 PM1 = SIGN(PMASS1**2,PMASS1)
17989 PM2 = SIGN(PMASS2**2,PMASS2)
17990 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
17992 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
17993 & *(PINITA(4)+PINITA(5)))
17996 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17997 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17998 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18001 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
18002 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18005 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
18006 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18011 *------- treatment of final state
18015 IF (NLOOP.GT.1) SCPOT = 0.10D0
18016 C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18028 DO 900 I=NPOINT(4),NHKK
18030 IF (ISTHKK(I).EQ.1) THEN
18031 IF (IDBAM(I).EQ.7) GOTO 900
18034 * particle moving into forward direction
18035 IF (PHKK(3,I).GE.ZERO) THEN
18036 * most likely to be effected by projectile potential
18038 * there is no projectile nucleus, try target
18039 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18041 IF (IP.GT.1) IOTHER = 1
18042 * there is no target nucleus --> skip
18043 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18045 * particle moving into backward direction
18047 * most likely to be effected by target potential
18049 * there is no target nucleus, try projectile
18050 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18052 IF (IT.GT.1) IOTHER = 1
18053 * there is no projectile nucleus --> skip
18054 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18058 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18059 * =1: particle is not in overlap-region AND is inside target (2)
18060 * =2: particle is not in overlap-region AND is inside projectile (1)
18061 * flag particles which are inside the nucleus ipot but not in its
18063 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18064 IF (IDBAM(I).NE.0) THEN
18065 * baryons: keep all nucleons and all others where flag is set
18066 IF (IIBAR(IDBAM(I)).NE.0) THEN
18067 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18070 PMOMB(NOB) = PHKK(3,I)
18071 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
18072 & +1000000*IOTHER+I,IFLG)
18074 * mesons: keep only those mesons where flag is set
18076 IF (IFLG.GT.0) THEN
18078 PMOMM(NOM) = PHKK(3,I)
18079 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
18086 * sort particles in the arrays according to increasing long. momentum
18087 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18088 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18090 * shuffle indices into one and the same array according to the later
18091 * sequence of correction
18095 IF (PMOMB(I).GT.ZERO) GOTO 911
18097 IDXCOR(NCOR) = IDXB(I)
18103 IF (PMOMB(I).LT.ZERO) GOTO 913
18105 IDXCOR(NCOR) = IDXB(I)
18110 IF (PMOMB(I).GT.ZERO) THEN
18112 IDXCOR(NCOR) = IDXB(I)
18120 IDXCOR(NCOR) = IDXB(I)
18124 IF (PMOMM(I).GT.ZERO) GOTO 926
18126 IDXCOR(NCOR) = IDXM(I)
18131 IF (PMOMM(I).LT.ZERO) GOTO 928
18133 IDXCOR(NCOR) = IDXM(I)
18137 C IF (NEVHKK.EQ.484) THEN
18138 C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18139 C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
18140 C WRITE(LOUT,9001) NOB,NOM,NCOR
18141 C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18142 C WRITE(LOUT,'(/,A)') ' baryons '
18144 CC J = IABS(IDXB(I))
18145 CC INDEX = J-IABS(J/10000000)*10000000
18146 C IPOT = IABS(IDXB(I))/10000000
18147 C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18148 C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18149 C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18151 C WRITE(LOUT,'(/,A)') ' mesons '
18153 CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18154 C IPOT = IABS(IDXM(I))/10000000
18155 C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18156 C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18157 C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18159 C 9002 FORMAT(1X,4I14,E14.5)
18160 C WRITE(LOUT,'(/,A)') ' all '
18162 CC J = IABS(IDXCOR(I))
18163 CC INDEX = J-IABS(J/10000000)*10000000
18164 CC IPOT = IABS(IDXCOR(I))/10000000
18165 C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18166 C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18167 C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18169 C 9003 FORMAT(1X,4I14)
18173 IPOT = IABS(IDXCOR(ICOR))/10000000
18174 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18175 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18180 * reduction of particle momentum by corresponding nuclear potential
18181 * (this applies only if Fermi-momenta are requested)
18185 * Lorentz-transformation into the rest system of the selected nucleus
18187 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18188 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18189 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18190 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18194 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18195 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18196 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18197 IF (IOULEV(3).GT.0)
18198 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18199 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
18200 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18201 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
18209 * the correction for nuclear potential effects is applied to as many
18210 * p/n as many nucleons were wounded; the momenta of other final state
18211 * particles are corrected only if they materialize inside the corresp.
18212 * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18213 * = 3 part. outside proj. and targ., >=10 in overlapping region)
18214 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18215 IF (IPOT.EQ.1) THEN
18216 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18217 * this is most likely a wounded nucleon
18219 C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18220 C & +(VHKK(2,IPW(JPW))/FM2MM)**2
18221 C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
18222 C RAD = RNUCLE*DBLE(IP)**ONETHI
18223 C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18224 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18226 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18230 * correct only if part. was materialized inside nucleus
18231 * and if it is ouside the overlapping region
18232 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18233 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18237 ELSEIF (IPOT.EQ.2) THEN
18238 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18239 * this is most likely a wounded nucleon
18241 C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18242 C & +(VHKK(2,ITW(JTW))/FM2MM)**2
18243 C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
18244 C RAD = RNUCLE*DBLE(IT)**ONETHI
18245 C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18246 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18248 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18252 * correct only if part. was materialized inside nucleus
18253 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18254 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18260 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18261 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18266 IF (NLOOP.EQ.1) THEN
18267 * Coulomb energy correction:
18268 * the treatment of Coulomb potential correction is similar to the
18269 * one for nuclear potential
18270 IF (IDSEC.EQ.1) THEN
18271 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18273 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18276 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18279 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18281 IF (IICH(IDSEC).EQ.1) THEN
18282 * pos. particles: check if they are able to escape Coulomb potential
18283 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18284 ISTHKK(I) = 14+IPOT
18285 IF (ISTHKK(I).EQ.15) THEN
18287 PHKK(K,I) = PSEC0(K)
18288 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18290 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18291 IF (IDSEC.EQ.1) NPCW = NPCW-1
18292 ELSEIF (ISTHKK(I).EQ.16) THEN
18294 PHKK(K,I) = PSEC0(K)
18295 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18297 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18298 IF (IDSEC.EQ.1) NTCW = NTCW-1
18302 ELSEIF (IICH(IDSEC).EQ.-1) THEN
18303 * neg. particles: decrease energy by Coulomb-potential
18304 PSEC(4) = PSEC(4)-ETACOU(IPOT)
18311 IF (PSEC(4).LT.AMSEC) THEN
18312 IF (IOULEV(6).GT.0)
18313 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18314 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18315 & ' is not allowed to escape nucleus',/,
18316 & 8X,'id : ',I3,' reduced energy: ',E15.4,
18318 ISTHKK(I) = 14+IPOT
18319 IF (ISTHKK(I).EQ.15) THEN
18321 PHKK(K,I) = PSEC0(K)
18322 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18324 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18325 IF (IDSEC.EQ.1) NPCW = NPCW-1
18326 ELSEIF (ISTHKK(I).EQ.16) THEN
18328 PHKK(K,I) = PSEC0(K)
18329 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18331 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18332 IF (IDSEC.EQ.1) NTCW = NTCW-1
18337 IF (JPMOD.EQ.1) THEN
18338 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18339 * 4-momentum after correction for nuclear potential
18341 PSEC(K) = PSEC(K)*PSECN/PSECO
18344 * store recoil momentum from particles escaping the nuclear potentials
18346 IF (IPOT.EQ.1) THEN
18347 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18348 ELSEIF (IPOT.EQ.2) THEN
18349 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18353 * transform momentum back into n-n cms
18355 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18356 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18364 PFSP(K) = PFSP(K)+PHKK(K,I)
18369 DO 33 I=NPOINT(4),NHKK
18370 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18371 PFSP(1) = PFSP(1)+PHKK(1,I)
18372 PFSP(2) = PFSP(2)+PHKK(2,I)
18373 PFSP(3) = PFSP(3)+PHKK(3,I)
18374 PFSP(4) = PFSP(4)+PHKK(4,I)
18379 PRCLPR(K) = TRCLPR(K)
18380 PRCLTA(K) = TRCLTA(K)
18383 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18384 * hadron-nucleus interactions: get residual momentum from energy-
18385 * momentum conservation
18388 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18391 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18392 * accumulated recoil momenta of particles leaving the spectators
18393 * transform accumulated recoil momenta of residual nuclei into
18397 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18400 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18401 C IF (IP.GT.1) THEN
18402 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18403 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18406 PRCLTA(3) = PRCLTA(3)+PINITA(3)
18407 PRCLTA(4) = PRCLTA(4)+PINITA(4)
18411 * check momenta of residual nuclei
18413 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18415 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18417 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18419 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18421 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18422 **sr 19.12. changed to avoid output when used with phojet
18425 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18426 C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18427 C & CALL DT_EVTOUT(4)
18428 IF (IREJ1.GT.0) RETURN
18434 *$ CREATE DT_SCN4BA.FOR
18437 *===scn4ba=============================================================*
18439 SUBROUTINE DT_SCN4BA
18441 ************************************************************************
18442 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
18443 * This version dated 12.12.95 is written by S. Roesler. *
18444 ************************************************************************
18446 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18448 PARAMETER ( LINP = 10 ,
18451 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18455 PARAMETER (NMXHKK=200000)
18456 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18457 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18458 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18459 * extended event history
18460 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18461 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18463 * particle properties (BAMJET index convention)
18465 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18466 & IICH(210),IIBAR(210),K1(210),K2(210)
18467 * properties of interacting particles
18468 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18469 * nuclear potential
18471 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18472 & EBINDP(2),EBINDN(2),EPOT(2,210),
18473 & ETACOU(2),ICOUL,LFERMI
18474 * treatment of residual nuclei: wounded nucleons
18475 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18476 * treatment of residual nuclei: 4-momenta
18477 LOGICAL LRCLPR,LRCLTA
18478 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18479 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18481 DIMENSION PLAB(2,5),PCMS(4)
18485 * get number of wounded nucleons
18502 * projectile nucleons wounded in primary interaction and in fzc
18503 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18507 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18508 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
18509 C IF (IP.GT.1) THEN
18511 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18514 * target nucleons wounded in primary interaction and in fzc
18515 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18519 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18520 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
18523 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18526 ELSEIF (ISTHKK(I).EQ.13) THEN
18528 ELSEIF (ISTHKK(I).EQ.14) THEN
18533 DO 11 I=NPOINT(4),NHKK
18534 * baryons which are unable to escape the nuclear potential of proj.
18535 IF (ISTHKK(I).EQ.15) THEN
18538 IF (IIBAR(IDBAM(I)).NE.0) THEN
18540 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18543 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18545 * baryons which are unable to escape the nuclear potential of targ.
18546 ELSEIF (ISTHKK(I).EQ.16) THEN
18549 IF (IIBAR(IDBAM(I)).NE.0) THEN
18551 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18554 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18559 * residual nuclei so far
18563 * ckeck for "residual nuclei" consisting of one nucleon only
18564 * treat it as final state particle
18565 IF (IRESP.EQ.1) THEN
18567 IST = ISTHKK(ISGLPR)
18568 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18569 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18570 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18571 IF (IST.EQ.13) THEN
18572 ISTHKK(ISGLPR) = 11
18576 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18577 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18578 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18579 NOBAM(NHKK) = NOBAM(ISGLPR)
18580 JDAHKK(1,ISGLPR) = NHKK
18582 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18585 IF (IREST.EQ.1) THEN
18587 IST = ISTHKK(ISGLTA)
18588 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18589 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18590 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18591 IF (IST.EQ.14) THEN
18592 ISTHKK(ISGLTA) = 12
18596 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18597 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18598 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18599 NOBAM(NHKK) = NOBAM(ISGLTA)
18600 JDAHKK(1,ISGLTA) = NHKK
18602 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18606 * get nuclear potential corresp. to the residual nucleus
18611 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18613 * baryons unable to escape the nuclear potential are treated as
18614 * excited nucleons (ISTHKK=15,16)
18615 DO 3 I=NPOINT(4),NHKK
18616 IF (ISTHKK(I).EQ.1) THEN
18618 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18619 * final state n and p not being outside of both nuclei are considered
18622 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
18623 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
18624 * Lorentz-trsf. into proj. rest sys. for those being inside proj.
18625 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18626 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18628 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18629 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18630 & (PLAB(1,4)+PLABT) ))
18631 EKIN = PLAB(1,4)-PLAB(1,5)
18632 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18633 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18635 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
18636 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
18637 * Lorentz-trsf. into targ. rest sys. for those being inside targ.
18638 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18639 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18641 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18642 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18643 & (PLAB(2,4)+PLABT) ))
18644 EKIN = PLAB(2,4)-PLAB(2,5)
18645 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18646 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18648 IF (PHKK(3,I).GE.ZERO) THEN
18650 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18653 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18655 IF (ISTHKK(I).NE.1) THEN
18658 PHKK(K,I) = PLAB(J,K)
18660 IF (ISTHKK(I).EQ.15) THEN
18662 IF (ID.EQ.1) NPCW = NPCW-1
18664 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18666 ELSEIF (ISTHKK(I).EQ.16) THEN
18668 IF (ID.EQ.1) NTCW = NTCW-1
18670 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18678 * again: get nuclear potential corresp. to the residual nucleus
18683 c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18684 cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18685 c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18687 c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18688 cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18689 c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18691 C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18692 C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18693 C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18694 C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18695 AFERP = FERMOD+0.1D0
18696 AFERT = FERMOD+0.1D0
18698 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18703 *$ CREATE DT_FICONF.FOR
18706 *===ficonf=============================================================*
18708 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18710 ************************************************************************
18711 * Treatment of FInal CONFiguration including evaporation, fission and *
18712 * Fermi-break-up (for light nuclei only). *
18713 * Adopted from the original routine FINALE and extended to residual *
18714 * projectile nuclei. *
18715 * This version dated 12.12.95 is written by S. Roesler. *
18717 * Last change 27.12.2006 by S. Roesler. *
18718 ************************************************************************
18720 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18722 PARAMETER ( LINP = 10 ,
18725 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18726 PARAMETER (ANGLGB=5.0D-16)
18727 PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18730 PARAMETER (NMXHKK=200000)
18731 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18732 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18733 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18734 * extended event history
18735 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18736 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18738 * rejection counter
18739 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18740 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18741 & IREXCI(3),IRDIFF(2),IRINC
18742 * central particle production, impact parameter biasing
18743 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18744 * particle properties (BAMJET index convention)
18746 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18747 & IICH(210),IIBAR(210),K1(210),K2(210)
18748 * treatment of residual nuclei: 4-momenta
18749 LOGICAL LRCLPR,LRCLTA
18750 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18751 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18752 * treatment of residual nuclei: properties of residual nuclei
18753 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18754 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18755 & NTOTFI(2),NPROFI(2)
18756 * statistics: residual nuclei
18757 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18758 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18759 & NINCST(2,4),NINCEV(2),
18760 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18761 & NRESPB(2),NRESCH(2),NRESEV(4),
18762 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18764 * flags for input different options
18765 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18766 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18767 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18768 * (original name: FINUC)
18769 PARAMETER (MXP=999)
18770 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
18771 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18772 & TKI (MXP), PLR (MXP), WEI (MXP),
18773 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18775 * (original name: RESNUC)
18776 LOGICAL LRNFSS, LFRAGM
18777 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18778 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18779 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
18780 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
18781 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18782 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18783 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18784 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18786 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
18787 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
18788 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18789 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18790 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18791 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18792 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
18793 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
18794 * (original name: PAREVT)
18795 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18796 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18797 PARAMETER ( NALLWP = 39 )
18798 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18799 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18800 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18801 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18803 COMMON /DTEVNO/ NEVENT,ICASCA
18805 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18806 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18807 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18809 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18811 DATA EXC,NEXC /520*ZERO,520*0/
18812 DATA EXPNUC /4.0D-3,4.0D-3/
18818 * skip residual nucleus treatment if not requested or in case
18819 * of central collisions
18820 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18847 * number of final state particles
18848 IF (ABS(ISTHKK(I)).EQ.1) THEN
18853 * properties of remaining nucleon configurations
18855 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18856 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18858 IF (MO1(KF).EQ.0) MO1(KF) = I
18860 * position of residual nucleus = average position of nucleons
18862 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18863 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18865 * total number of particles contributing to each residual nucleus
18866 NTOT(KF) = NTOT(KF)+1
18869 * total charge of residual nuclei
18870 NQ(KF) = NQ(KF)+IICH(IDTMP)
18871 * number of protons
18872 IF (IDHKK(I).EQ.2212) THEN
18873 NPRO(KF) = NPRO(KF)+1
18874 * number of neutrons
18875 ELSEIF (IDHKK(I).EQ.2112) THEN
18878 * number of baryons other than n, p
18879 IF (IIBAR(IDTMP).EQ.1) THEN
18881 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18883 * any other mesons (status set to 1)
18884 C WRITE(LOUT,1002) KF,IDTMP
18885 C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
18886 C & ' containing meson ',I4,', status set to 1')
18889 IDXTMP = IDXPAR(KF)
18890 NTOT(KF) = NTOT(KF)-1
18894 IDXPAR(KF) = IDXTMP
18898 * reject elastic events (def: one final state particle = projectile)
18899 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18900 IREXCI(3) = IREXCI(3)+1
18905 * check if one nucleus disappeared..
18906 C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18908 C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18911 C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18913 C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18922 * get the average of the nucleon positions
18923 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18924 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18925 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18926 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18928 * mass number and charge of residual nuclei
18929 AIF(I) = DBLE(NTOT(I))
18930 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18931 IF (NTOT(I).GT.1) THEN
18932 * masses of residual nuclei in ground state
18933 AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18934 * masses of residual nuclei
18935 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18936 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18937 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18939 * M_res^2 < 0 : configuration not allowed
18941 * a) re-calculate E_exc with scaled nuclear potential
18942 * (conditional jump to label 9998)
18943 * b) or reject event if N_loop(max) is exceeded
18944 * (conditional jump to label 9999)
18946 IF (AMRCL(I).LE.ZERO) THEN
18947 IF (IOULEV(3).GT.0)
18948 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18950 1000 FORMAT(1X,'warning! negative excitation energy',/,
18954 IF (NLOOP.LE.500) THEN
18957 IREXCI(2) = IREXCI(2)+1
18961 * 0 < M_res < M_res0 : mass below ground-state mass
18963 * a) we had residual nuclei with mass N_tot and reasonable E_exc
18964 * before- assign average E_exc of those configurations to this
18965 * one ( Nexc(i,N_tot) > 0 )
18966 * b) or (and this applies always if run in transport codes) go up
18967 * one mass number and
18968 * i) if mass now larger than proj/targ mass or if run in
18969 * transport codes assign average E_exc per wounded nucleon
18970 * x number of wounded nucleons (Inuc-Ntot)
18971 * ii) or assign average E_exc of those configurations to this
18972 * one ( Nexc(i,m) > 0 )
18974 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18976 M = MIN(NTOT(I),260)
18977 IF (NEXC(I,M).GT.0) THEN
18978 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18982 **sr corrected 27.12.06
18983 * IF (M.GE.INUC(I)) THEN
18984 * AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18985 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18986 IF ( INUC (I) .GT. NTOT (I) ) THEN
18987 AMRCL(I) = AMRCL0(I)
18988 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
18990 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
18994 IF (NEXC(I,M).GT.0) THEN
18995 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19001 EEXC(I) = AMRCL(I)-AMRCL0(I)
19004 * M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
19006 * a) re-calculate E_exc with scaled nuclear potential
19007 * (conditional jump to label 9998)
19008 * b) or reject event if N_loop(max) is exceeded
19009 * (conditional jump to label 9999)
19012 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19013 IF (IOULEV(3).GT.0)
19014 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19015 1004 FORMAT(1X,'warning! too high excitation energy',/,
19016 & I4,1P,2E15.4,3I5)
19019 IF (NLOOP.LE.500) THEN
19022 IREXCI(2) = IREXCI(2)+1
19026 * Otherwise (reasonable E_exc) :
19027 * E_exc = M_res - M_res0
19028 * in addition: calculate and save E_exc per wounded nucleon as
19029 * well as E_exc in <E_exc> counter
19032 * excitation energies of residual nuclei
19033 EEXC(I) = AMRCL(I)-AMRCL0(I)
19034 **sr 27.12.06 new excitation energy correction by A.F.
19036 * all parts with Ilcopt<3 commented since not used
19038 * still to be done/decided:
19039 * Increase Icor and put back both residual nuclei on mass shell
19040 * with the exciting correction further below.
19041 * For the moment the modification in the excitation energy is simply
19042 * corrected by scaling the energy of the residual nucleus.
19047 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19048 IF ( ILCOPT .LE. 2 ) THEN
19049 C* Patch for Fermi momentum reduction correlated with impact parameter:
19050 C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19051 C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19052 C AKPRHO = ONE - DLKPRH
19053 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19054 C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
19056 C* REDORI = 0.75D+00
19058 C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19061 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19062 * Take out roughly one/half of the skin:
19063 RDCORE = RDCORE - 0.5D+00
19065 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19066 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19067 FRCFLL = ONE - PRSKIN
19068 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19069 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19071 IF ( NNCHIT .GT. 0 ) THEN
19072 C IF ( ILCOPT .EQ. 1 ) THEN
19073 C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19074 C DO 1220 NCH = 1, 10
19075 C ETAETA = ( ONE - SKINRH**INUC(I)
19076 C & - DBLE(INUC(I))* ( ONE - FRCFLL )
19077 C & * ( ONE - SKINRH ) )
19078 C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
19079 C & * ( ONE - FRCFLL) * SKINRH )
19080 C SKINRH = SKINRH * ( ONE + ETAETA )
19082 C PRSKIN = SKINRH**(NNCHIT-1)
19083 C ELSE IF ( ILCOPT .EQ. 2 ) THEN
19084 C PRSKIN = ONE - FRCFLL
19087 DO 1230 NCH = 1, NNCHIT
19088 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19089 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19090 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19092 PRFRMI = ( ONE - 2.D+00 * DLKPRH
19093 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19095 REDCTN = REDCTN + PRFRMI**2
19097 REDCTN = REDCTN / DBLE (NNCHIT)
19101 EEXC (I) = EEXC (I) * REDCTN / REDORI
19102 AMRCL (I) = AMRCL0 (I) + EEXC (I)
19103 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19106 IF (ICASCA.EQ.0) THEN
19107 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19108 M = MIN(NTOT(I),260)
19109 EXC(I,M) = EXC(I,M)+EEXC(I)
19110 NEXC(I,M) = NEXC(I,M)+1
19113 ELSEIF (NTOT(I).EQ.1) THEN
19115 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
19125 PRCLPR(5) = AMRCL(1)
19126 PRCLTA(5) = AMRCL(2)
19128 IF (ICOR.GT.0) THEN
19129 IF (INORCL.EQ.0) THEN
19130 * one or both residual nuclei consist of one nucleon only, transform
19131 * this nucleon on mass shell
19133 P1IN(K) = PRCL(1,K)
19134 P2IN(K) = PRCL(2,K)
19138 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19139 IF (IREJ1.GT.0) THEN
19140 WRITE(LOUT,*) 'ficonf-mashel rejection'
19144 PRCL(1,K) = P1OUT(K)
19145 PRCL(2,K) = P2OUT(K)
19146 PRCLPR(K) = P1OUT(K)
19147 PRCLTA(K) = P2OUT(K)
19149 PRCLPR(5) = AMRCL(1)
19150 PRCLTA(5) = AMRCL(2)
19152 IF (IOULEV(3).GT.0)
19153 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19154 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19155 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19156 & AMRCL(2),AMRCL(2)-AMRCL0(2)
19157 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
19158 & ' correction',/,11X,'at event',I8,
19159 & ', nucleon config. 1:',2I4,' 2:',2I4,
19161 IF (NLOOP.LE.500) THEN
19164 IREXCI(1) = IREXCI(1)+1
19170 C IF (NRESEV(1).NE.NEVHKK) THEN
19171 C NRESEV(1) = NEVHKK
19172 C NRESEV(2) = NRESEV(2)+1
19174 NRESEV(2) = NRESEV(2)+1
19176 EXCDPM(I) = EXCDPM(I)+EEXC(I)
19177 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19178 NRESTO(I) = NRESTO(I)+NTOT(I)
19179 NRESPR(I) = NRESPR(I)+NPRO(I)
19180 NRESNU(I) = NRESNU(I)+NN(I)
19181 NRESBA(I) = NRESBA(I)+NH(I)
19182 NRESPB(I) = NRESPB(I)+NHPOS(I)
19183 NRESCH(I) = NRESCH(I)+NQ(I)
19189 * initialize evaporation counter
19191 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19192 & (EEXC(I).GT.ZERO)) THEN
19193 * put residual nuclei into DTEVT1
19195 JMASS = INT( AIF(I))
19196 JCHAR = INT(AIZF(I))
19197 * the following patch is required to transmit the correct excitation
19199 IF (ITRSPT.EQ.1) THEN
19200 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19201 & (IOULEV(3).GT.0))
19203 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19204 & AMRCL(I),AMRCL0(I),EEXC(I)
19206 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19208 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19210 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19213 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19214 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19219 VHKK(J,NHKK) = VRCL(I,J)
19220 WHKK(J,NHKK) = WRCL(I,J)
19222 * interface to evaporation module - fill final residual nucleus into
19224 * fill resnuc only if code is not used as event generator in Fluka
19225 IF (ITRSPT.NE.1) THEN
19229 IBRES = NPRO(I)+NN(I)+NH(I)
19230 ICRES = NPRO(I)+NHPOS(I)
19233 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
19234 * ground state mass of the residual nucleus (should be equal to AM0T)
19236 AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19239 * kinetic energy of residual nucleus
19240 TVRECL = PRCL(I,4)-AMRCL(I)
19241 * excitation energy of residual nucleus
19244 PTRES = SQRT(ABS(TVRECL*(TVRECL+
19245 & 2.0D0*(AMMRES+TVCMS))))
19246 IF (PTOLD.LT.ANGLGB) THEN
19247 CALL DT_RACO(PXRES,PYRES,PZRES)
19250 PXRES = PXRES*PTRES/PTOLD
19251 PYRES = PYRES*PTRES/PTOLD
19252 PZRES = PZRES*PTRES/PTOLD
19253 * zero counter of secondaries from evaporation
19258 * put evaporated particles and residual nuclei to DTEVT1
19260 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19263 EXCEVA(I) = EXCEVA(I)+EXCITF
19270 C9998 IREXCI(1) = IREXCI(1)+1
19279 *$ CREATE DT_EVA2HE.FOR
19282 *====eva2he============================================================*
19284 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19286 ************************************************************************
19287 * Interface between common's of evaporation module (FKFINU,FKFHVY) *
19289 * MO DTEVT1-index of "mother" (residual) nucleus before evap. *
19290 * EEXCF exitation energy of residual nucleus after evaporation *
19291 * IRCL = 1 projectile residual nucleus *
19292 * = 2 target residual nucleus *
19293 * This version dated 19.04.95 is written by S. Roesler. *
19295 * Last change 27.12.2006 by S. Roesler. *
19296 ************************************************************************
19298 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19300 PARAMETER ( LINP = 10 ,
19303 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19306 PARAMETER (NMXHKK=200000)
19307 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19308 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19309 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19310 * Note: DTEVT2 - special use for heavy fragments !
19311 * (IDRES(I) = mass number, IDXRES(I) = charge)
19312 * extended event history
19313 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19314 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19316 * particle properties (BAMJET index convention)
19318 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19319 & IICH(210),IIBAR(210),K1(210),K2(210)
19320 * flags for input different options
19321 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19322 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19323 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19324 * statistics: residual nuclei
19325 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19326 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19327 & NINCST(2,4),NINCEV(2),
19328 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19329 & NRESPB(2),NRESCH(2),NRESEV(4),
19330 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19332 * treatment of residual nuclei: properties of residual nuclei
19333 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19334 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19335 & NTOTFI(2),NPROFI(2)
19336 * (original name: FINUC)
19337 PARAMETER (MXP=999)
19338 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
19339 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19340 & TKI (MXP), PLR (MXP), WEI (MXP),
19341 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19343 * (original name: FHEAVY,FHEAVC)
19344 PARAMETER ( MXHEAV = 100 )
19346 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19347 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19348 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19349 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
19350 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
19351 & IBHEAV ( 12 ) , NPHEAV
19352 COMMON /FKFHVC/ ANHEAV ( 12 )
19353 * (original name: RESNUC)
19354 LOGICAL LRNFSS, LFRAGM
19355 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19356 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19357 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19358 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
19359 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19360 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19361 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19362 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19365 DIMENSION IPTOKP(39)
19366 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19367 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19368 & 100, 101, 97, 102, 98, 103, 109, 115 /
19372 * skip if evaporation package is not included
19373 IF (.NOT.LEVAPO) RETURN
19376 IF (NRESEV(3).NE.NEVHKK) THEN
19378 NRESEV(4) = NRESEV(4)+1
19382 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19384 * mass number/charge of residual nucleus before evaporation
19388 * protons/neutrons/gammas
19393 ID = IPTOKP(KPART(I))
19394 IDPDG = IDT_IPDGHA(ID)
19395 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19396 & (2.0D0*MAX(TKI(I),TINY10))
19397 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19398 WRITE(LOUT,1000) ID,AM,AAM(ID)
19399 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
19400 & 'particle',I3,2E10.3)
19403 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19405 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19406 IBTOT = IBTOT-IIBAR(ID)
19407 IZTOT = IZTOT-IICH(ID)
19412 PX = CXHEAV(I)*PHEAVY(I)
19413 PY = CYHEAV(I)*PHEAVY(I)
19414 PZ = CZHEAV(I)*PHEAVY(I)
19416 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19417 & (2.0D0*MAX(TKHEAV(I),TINY10))
19419 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19420 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19422 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19423 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19424 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19427 IF (IBRES.GT.0) THEN
19428 * residual nucleus after evaporation
19430 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19435 NTOTFI(IRCL) = IBRES
19436 NPROFI(IRCL) = ICRES
19437 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19438 IBTOT = IBTOT-IBRES
19439 IZTOT = IZTOT-ICRES
19441 * count events with fission
19442 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19443 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19445 * energy-momentum conservation check
19446 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19447 C IF (IREJ.GT.0) THEN
19448 C CALL DT_EVTOUT(4)
19449 C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19451 * baryon-number/charge conservation check
19452 IF (IBTOT+IZTOT.NE.0) THEN
19453 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19454 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
19455 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
19461 *$ CREATE DT_EBIND.FOR
19464 *===ebind==============================================================*
19466 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19468 ************************************************************************
19469 * Binding energy for nuclei. *
19470 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
19472 * IZ atomic number *
19473 * This version dated 5.5.95 is updated by S. Roesler. *
19474 ************************************************************************
19476 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19478 PARAMETER ( LINP = 10 ,
19481 PARAMETER (ZERO=0.0D0)
19483 DATA A1, A2, A3, A4, A5
19484 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19486 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19487 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
19492 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19493 & -A4*(IA-2*IZ)**2/AA
19494 IF (MOD(IA,2).EQ.1) THEN
19496 ELSEIF (MOD(IZ,2).EQ.1) THEN
19501 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19506 **sr 30.6. routine replaced completely
19507 *$ CREATE DT_ENERGY.FOR
19510 *=== energy ===========================================================*
19512 DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19514 C INCLUDE '(DBLPRC)'
19516 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19518 * (original name: GLOBAL)
19519 PARAMETER ( KALGNM = 2 )
19520 PARAMETER ( ANGLGB = 5.0D-16 )
19521 PARAMETER ( ANGLSQ = 2.5D-31 )
19522 PARAMETER ( AXCSSV = 0.2D+16 )
19523 PARAMETER ( ANDRFL = 1.0D-38 )
19524 PARAMETER ( AVRFLW = 1.0D+38 )
19525 PARAMETER ( AINFNT = 1.0D+30 )
19526 PARAMETER ( AZRZRZ = 1.0D-30 )
19527 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19528 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19529 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19530 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19531 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
19532 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
19533 PARAMETER ( CSNNRM = 2.0D-15 )
19534 PARAMETER ( DMXTRN = 1.0D+08 )
19535 PARAMETER ( ZERZER = 0.D+00 )
19536 PARAMETER ( ONEONE = 1.D+00 )
19537 PARAMETER ( TWOTWO = 2.D+00 )
19538 PARAMETER ( THRTHR = 3.D+00 )
19539 PARAMETER ( FOUFOU = 4.D+00 )
19540 PARAMETER ( FIVFIV = 5.D+00 )
19541 PARAMETER ( SIXSIX = 6.D+00 )
19542 PARAMETER ( SEVSEV = 7.D+00 )
19543 PARAMETER ( EIGEIG = 8.D+00 )
19544 PARAMETER ( ANINEN = 9.D+00 )
19545 PARAMETER ( TENTEN = 10.D+00 )
19546 PARAMETER ( HLFHLF = 0.5D+00 )
19547 PARAMETER ( ONETHI = ONEONE / THRTHR )
19548 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19549 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19550 PARAMETER ( THRTWO = THRTHR / TWOTWO )
19551 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19552 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19553 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19554 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19555 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19556 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19557 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19558 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
19559 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
19560 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
19561 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
19562 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19563 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19564 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19565 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19566 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19567 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19568 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19569 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19570 PARAMETER ( CLIGHT = 2.99792458 D+10 )
19571 PARAMETER ( AVOGAD = 6.0221367 D+23 )
19572 PARAMETER ( BOLTZM = 1.380658 D-23 )
19573 PARAMETER ( AMELGR = 9.1093897 D-28 )
19574 PARAMETER ( PLCKBR = 1.05457266 D-27 )
19575 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19576 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19577 PARAMETER ( AMUGRM = 1.6605402 D-24 )
19578 PARAMETER ( AMMUMU = 0.113428913 D+00 )
19579 PARAMETER ( AMPRMU = 1.007276470 D+00 )
19580 PARAMETER ( AMNEMU = 1.008664904 D+00 )
19581 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19582 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19583 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19584 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19585 PARAMETER ( PLABRC = 0.197327053 D+00 )
19586 PARAMETER ( AMELCT = 0.51099906 D-03 )
19587 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19588 PARAMETER ( AMMUON = 0.105658389 D+00 )
19589 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19590 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19591 PARAMETER ( AMDEUT = 1.87561339 D+00 )
19592 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19594 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19595 PARAMETER ( BLTZMN = 8.617385 D-14 )
19596 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19597 PARAMETER ( GFOHB3 = 1.16639 D-05 )
19598 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19599 PARAMETER ( SIN2TW = 0.2319 D+00 )
19600 PARAMETER ( GEVMEV = 1.0 D+03 )
19601 PARAMETER ( EMVGEV = 1.0 D-03 )
19602 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
19603 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19604 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19605 LOGICAL LGBIAS, LGBANA
19606 COMMON /FKGLOB/ LGBIAS, LGBANA
19607 C INCLUDE '(DIMPAR)'
19609 PARAMETER ( MXXRGN = 5000 )
19610 PARAMETER ( MXXMDF = 82 )
19611 PARAMETER ( MXXMDE = 54 )
19612 PARAMETER ( MFSTCK = 1000 )
19613 PARAMETER ( MESTCK = 100 )
19614 PARAMETER ( NALLWP = 39 )
19615 PARAMETER ( NELEMX = 80 )
19616 PARAMETER ( MPDPDX = 8 )
19617 PARAMETER ( ICOMAX = 180 )
19618 PARAMETER ( NSTBIS = 304 )
19619 PARAMETER ( IDMAXP = 220 )
19620 PARAMETER ( IDMXDC = 640 )
19621 PARAMETER ( MKBMX1 = 1 )
19622 PARAMETER ( MKBMX2 = 1 )
19623 C INCLUDE '(IOUNIT)'
19625 PARAMETER ( LUNIN = 5 )
19626 PARAMETER ( LUNOUT = 6 )
19627 **sr 19.5. set error output-unit from 15 to 6
19628 PARAMETER ( LUNERR = 6 )
19629 PARAMETER ( LUNBER = 14 )
19630 PARAMETER ( LUNECH = 8 )
19631 PARAMETER ( LUNFLU = 13 )
19632 PARAMETER ( LUNGEO = 16 )
19633 PARAMETER ( LUNPMF = 12 )
19634 PARAMETER ( LUNRAN = 2 )
19635 PARAMETER ( LUNXSC = 9 )
19636 PARAMETER ( LUNDET = 17 )
19637 PARAMETER ( LUNRAY = 10 )
19638 PARAMETER ( LUNRDB = 1 )
19639 PARAMETER ( LUNPGO = 7 )
19640 PARAMETER ( LUNPGS = 4 )
19641 PARAMETER ( LUNSCR = 3 )
19643 *----------------------------------------------------------------------*
19645 * Revised version of the original routine from EVAP: *
19647 * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
19650 * Last change on 19-sep-95 by Alfredo Ferrari *
19652 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19653 * !!! It is supposed to be used with the updated atomic !!! *
19654 * !!! mass data file !!! *
19655 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19657 *----------------------------------------------------------------------*
19659 * Mass number below which "unknown" isotopes out of the Z-interval
19660 * reported in the mass tabulations are completely unstable and made
19661 * up by Z proton masses + N neutron masses:
19662 PARAMETER ( KAFREE = 4 )
19663 * Mass number below which "unknown" isotopes out of the Z-interval
19664 * reported in the mass tabulations are supposed to be particle unstable
19665 PARAMETER ( KAPUNS = 12 )
19666 * Minimum energy required for particle unstable isotopes
19667 PARAMETER ( DEPUNS = 0.5D+00 )
19669 * (original name: EVA0)
19670 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19671 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19672 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19673 * T (4,7), RMASS (297), ALPH (297), BET (297),
19674 * APRIME (250), IA (6), IZ (6)
19675 * (original name: ISOTOP)
19676 PARAMETER ( NAMSMX = 270 )
19677 PARAMETER ( NZGVAX = 15 )
19678 PARAMETER ( NISMMX = 574 )
19679 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
19680 & WAPISM (NISMMX), T12ISM (NISMMX),
19681 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19682 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
19683 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19684 & INWAPS (NAMSMX), JSPISM (NISMMX),
19685 & JPTISM (NISMMX), IZWISM (NISMMX),
19686 & INWISM (0:NAMSMX)
19688 CPH SAVE KA0, KZ0, IZ0
19689 DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19693 *======================================================================*
19695 * Entry ENergy - KNOWn *
19697 *======================================================================*
19698 ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19706 * +-------------------------------------------------------------------*
19707 * | Null residual nucleus:
19708 IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19709 IF ( IFLAG .EQ. 1 ) THEN
19717 * +-------------------------------------------------------------------*
19719 ELSE IF ( N .LE. 0 ) THEN
19720 IF ( N .LT. 0 ) THEN
19721 WRITE ( LUNOUT, * )
19722 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19724 WRITE ( LUNOUT, * )
19725 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19728 & ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19730 STOP 'DT_ENERGY:KA0-KZ0'
19733 IF ( IFLAG .EQ. 1 ) THEN
19734 DT_ENERGY = Z * WAPS ( 1, 2 )
19736 DT_ENKNOW = Z * WAPS ( 1, 2 )
19741 * +-------------------------------------------------------------------*
19743 ELSE IF ( KZ0 .LE. 0 ) THEN
19744 IF ( KZ0 .LT. 0 ) THEN
19745 WRITE ( LUNOUT, * )
19746 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19747 WRITE ( LUNOUT, * )
19748 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19750 &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19751 STOP 'DT_ENERGY:KZ0<0'
19754 IF ( IFLAG .EQ. 1 ) THEN
19755 DT_ENERGY = A * WAPS ( 1, 1 )
19757 DT_ENKNOW = A * WAPS ( 1, 1 )
19763 * +-------------------------------------------------------------------*
19764 * +-------------------------------------------------------------------*
19765 * | No actual nucleus
19767 * +-------------------------------------------------------------------*
19768 * +-------------------------------------------------------------------*
19769 * | A larger than maximum allowed:
19770 IF ( KA0 .GT. NAMSMX ) THEN
19772 IF ( IFLAG .EQ. 1 ) THEN
19773 DT_ENERGY = DT_ENRG( A, Z )
19775 DT_ENKNOW = DT_ENRG( A, Z )
19781 * +-------------------------------------------------------------------*
19782 IZZ = INWAPS ( KA0 )
19783 * +-------------------------------------------------------------------*
19784 * | Too much neutron rich with respect to the stability line:
19785 IF ( KZ0 .LT. IZZ ) THEN
19786 * | +----------------------------------------------------------------*
19787 * | | Up to A=Kafree all "bound" masses are known, set it unbound:
19788 IF ( KA0 .LE. KAFREE ) THEN
19791 * | +----------------------------------------------------------------*
19792 * | | Up to Kapuns: be sure it is particle unstable
19793 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19794 * | | Exp. excess mass for A,IZZ
19795 ENEEXP = WAPS ( KA0, 1 )
19796 * | | Cameron excess mass for A, IZZ
19797 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19798 * | | Cameron excess mass for A, Z
19799 DT_ENERGY = DT_ENRG( A, Z )
19800 * | | Use just the difference according to Cameron!!!
19801 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19802 JZZ = INWAPS ( KA0 - 1 )
19803 LZZ = INWAPS ( KA0 - 2 )
19804 * | | +-------------------------------------------------------------*
19805 * | | | Residual mass for n-decay known:
19806 IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19807 IZ0 = KZ0 - JZZ + 1
19808 DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19811 * | | +-------------------------------------------------------------*
19812 * | | | Residual mass for 2n-decay known:
19813 ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19814 IZ0 = KZ0 - LZZ + 1
19815 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19816 & ( WAPS (1,1) + DEPUNS ) )
19818 * | | +-------------------------------------------------------------*
19819 * | | | Set it unbound:
19824 * | | +-------------------------------------------------------------*
19826 * | +----------------------------------------------------------------*
19827 * | | Proceed as usual:
19829 * | | Exp. excess mass for A,IZZ
19830 ENEEXP = WAPS ( KA0, 1 )
19831 * | | Cameron excess mass for A, IZZ
19832 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19833 * | | Cameron excess mass for A, Z
19834 DT_ENERGY = DT_ENRG( A, Z )
19835 * | | Use just the difference according to Cameron!!!
19836 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19839 * | +----------------------------------------------------------------*
19840 * | Be sure not to have a positive energy state:
19841 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19843 IF ( IFLAG .EQ. 2 ) THEN
19844 DT_ENKNOW = DT_ENERGY
19849 * +-------------------------------------------------------------------*
19850 * | Too much proton rich with respect to the stability line:
19851 ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19852 * | +----------------------------------------------------------------*
19853 * | | Up to A=Kafree all "bound" masses are known, set it unbound:
19854 IF ( KA0 .LE. KAFREE ) THEN
19857 * | +----------------------------------------------------------------*
19858 * | | Up to Kapuns: be sure it is particle unstable
19859 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19860 * | | Exp. excess mass for A,IZZ+NZGVAX-1
19861 ENEEXP = WAPS ( KA0, NZGVAX )
19862 * | | Cameron excess mass for A, IZZ+NZGVAX-1
19863 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19864 * | | Cameron excess mass for A, Z
19865 DT_ENERGY = DT_ENRG( A, Z )
19866 * | | Use just the difference according to Cameron!!!
19867 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19868 JZZ = INWAPS ( KA0 - 1 )
19869 LZZ = INWAPS ( KA0 - 2 )
19870 * | | +-------------------------------------------------------------*
19871 * | | | Residual mass for p-decay known:
19872 IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19873 IZ0 = KZ0 - 1 - JZZ + 1
19874 DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19877 * | | +-------------------------------------------------------------*
19878 * | | | Residual mass for 2p-decay known:
19879 ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19881 IZ0 = KZ0 - 2 - LZZ + 1
19882 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19883 & ( WAPS (1,2) + DEPUNS ) )
19885 * | | +-------------------------------------------------------------*
19886 * | | | Set it unbound:
19891 * | | +-------------------------------------------------------------*
19893 * | +----------------------------------------------------------------*
19894 * | | Proceed as usual:
19896 * | | Exp. excess mass for A,IZZ+NZGVAX-1
19897 ENEEXP = WAPS ( KA0, NZGVAX )
19898 * | | Cameron excess mass for A, IZZ+NZGVAX-1
19899 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19900 * | | Cameron excess mass for A, Z
19901 DT_ENERGY = DT_ENRG( A, Z )
19902 * | | Use just the difference according to Cameron!!!
19903 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19906 * | +----------------------------------------------------------------*
19907 * | Be sure not to have a positive energy state:
19908 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19910 IF ( IFLAG .EQ. 2 ) THEN
19911 DT_ENKNOW = DT_ENERGY
19916 * +-------------------------------------------------------------------*
19917 * | Known isotope or anyway isotope "inside" the stability zone
19919 IZ0 = KZ0 - IZZ + 1
19920 DT_ENERGY = WAPS ( KA0, IZ0 )
19921 IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19922 * | +----------------------------------------------------------------*
19923 * | | Mass not known
19924 IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19926 IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19927 * | | +-------------------------------------------------------------*
19928 * | | | Set it unbound:
19929 IF ( KA0 .LE. KAFREE ) THEN
19932 * | | +-------------------------------------------------------------*
19933 * | | | Try to get a reasonable excess mass:
19936 * | | | +----------------------------------------------------------*
19937 * | | | | Check the closest one known:
19938 DO 500 JZZ = 1, NZGVAX
19939 IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19940 & ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19941 IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19944 * | | | +----------------------------------------------------------*
19946 * | | | Exp. excess mass for A,IZZ+JZ0-1
19947 ENEEXP = WAPS ( KA0, JZ0 )
19948 * | | | Cameron excess mass for A, IZZ+JZ0-1
19949 ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19950 * | | | Cameron excess mass for A, Z
19951 DT_ENERGY = DT_ENRG( A, Z )
19952 * | | | Use just the difference according to Cameron!!!
19953 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19957 * | | +-------------------------------------------------------------*
19958 * | | Be sure not to have a positive energy state:
19959 DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19962 * | +----------------------------------------------------------------*
19963 IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19967 * +-------------------------------------------------------------------*
19968 *=== End of Function Energy ===========================================*
19973 *$ CREATE DT_ENRG.FOR
19976 *=== enrg =============================================================*
19978 DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19980 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19983 PARAMETER ( ZERZER = 0.D+00 )
19984 PARAMETER ( ONEONE = 1.D+00 )
19985 PARAMETER ( LUNIN = 5 )
19986 PARAMETER ( LUNOUT = 6 )
19988 *----------------------------------------------------------------------*
19990 * Revised version of the original routine from EVAP: *
19992 * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
19995 * Last change on 01-oct-94 by Alfredo Ferrari *
19997 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19998 * !!! It is supposed to be used with the updated atomic !!! *
19999 * !!! mass data file !!! *
20000 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
20002 *----------------------------------------------------------------------*
20004 PARAMETER ( O16OLD = 931.145 D+00 )
20005 PARAMETER ( O16NEW = 931.19826D+00 )
20006 PARAMETER ( O16RAT = O16NEW / O16OLD )
20007 PARAMETER ( C12NEW = 931.49432D+00 )
20008 PARAMETER ( ADJUST = -8.322737768178909D-02 )
20009 PARAMETER ( AINFNT = 1.0D+30 )
20010 * (original name: EVA0)
20011 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20012 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20013 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20014 * T (4,7), RMASS (297), ALPH (297), BET (297),
20015 * APRIME (250), IA (6), IZ (6)
20017 CPH SAVE LFIRST, EXHYDR, EXNEUT
20018 DATA LFIRST / .TRUE. /
20023 C EXHYDR = DT_ENERGY( ONEONE, ONEONE )
20024 C EXNEUT = DT_ENERGY( ONEONE, ZERZER )
20032 IF ( IZ0 .LE. 0 ) THEN
20033 DT_ENRG = A * EXNEUT
20037 IF ( N .LE. 0 ) THEN
20038 DT_ENRG = Z * EXHYDR
20042 AM2ZOA=AM2ZOA*AM2ZOA
20043 A13 = RMASS(NINT(A))
20044 * A13 = A**.3333333333333333D+00
20046 EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20047 ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20048 & (1.D+00 -0.62025D+00*AM13*AM13)*
20049 & (A13*A13 -.62025D+00)
20050 EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20051 & AM13-1.5849D+00)*
20052 & AM13*AM13 +1.D+00)
20053 EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20054 & (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20056 DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20057 DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20058 DT_ENRG = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20060 *=== End of function Enrg =============================================*
20063 *$ CREATE DT_INCINI.FOR
20066 *=== incini ===========================================================*
20068 SUBROUTINE DT_INCINI
20070 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20073 PARAMETER ( ZERZER = 0.D+00 )
20074 PARAMETER ( ONEONE = 1.D+00 )
20075 PARAMETER ( TWOTWO = 2.D+00 )
20076 PARAMETER ( THRTHR = 3.D+00 )
20077 PARAMETER ( FOUFOU = 4.D+00 )
20078 PARAMETER ( EIGEIG = 8.D+00 )
20079 PARAMETER ( ANINEN = 9.D+00 )
20080 PARAMETER ( HLFHLF = 0.5D+00 )
20081 PARAMETER ( ONETHI = ONEONE / THRTHR )
20082 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20083 PARAMETER ( PLABRC = 0.197327053 D+00 )
20084 PARAMETER ( AMELCT = 0.51099906 D-03 )
20085 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20086 PARAMETER ( AMPRTN = 0.93827231 D+00 )
20087 PARAMETER ( AMNTRN = 0.93956563 D+00 )
20088 PARAMETER ( AMDEUT = 1.87561339 D+00 )
20089 PARAMETER ( EMVGEV = 1.0 D-03 )
20091 PARAMETER ( LUNOUT = 6 )
20093 *----------------------------------------------------------------------*
20095 * Created on 10 june 1990 by Alfredo Ferrari & Paola Sala *
20098 * Last change on 02-may-95 by Alfredo Ferrari *
20101 *----------------------------------------------------------------------*
20103 * (original name: FHEAVY,FHEAVC)
20104 PARAMETER ( MXHEAV = 100 )
20106 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20107 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20108 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20109 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
20110 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
20111 & IBHEAV ( 12 ) , NPHEAV
20112 COMMON /FKFHVC/ ANHEAV ( 12 )
20113 * (original name: INPFLG)
20114 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20115 * (original name: FRBKCM)
20116 PARAMETER ( MXFFBK = 6 )
20117 PARAMETER ( MXZFBK = 9 )
20118 PARAMETER ( MXNFBK = 10 )
20119 PARAMETER ( MXAFBK = 16 )
20120 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20121 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20122 PARAMETER ( NXAFBK = MXAFBK + 1 )
20123 PARAMETER ( MXPSST = 300 )
20124 PARAMETER ( MXPSFB = 41000 )
20125 LOGICAL LFRMBK, LNCMSS
20126 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20127 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20128 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20129 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20130 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20131 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20132 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20133 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20134 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20135 * (original name: NUCDAT)
20136 PARAMETER ( AMUAMU = AMUGEV )
20137 PARAMETER ( AMPROT = AMPRTN )
20138 PARAMETER ( AMNEUT = AMNTRN )
20139 PARAMETER ( AMELEC = AMELCT )
20140 PARAMETER ( R0NUCL = 1.12 D+00 )
20141 PARAMETER ( RCCOUL = 1.7 D+00 )
20142 PARAMETER ( FERTHO = 14.33 D-09 )
20143 PARAMETER ( EXPEBN = 2.39 D+00 )
20144 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20145 PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20146 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
20147 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
20148 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
20149 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20150 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20151 PARAMETER ( GAMMIN = 1.0D-06 )
20152 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20153 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20154 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
20155 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
20156 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20157 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20158 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20159 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20160 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
20161 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
20162 * (original name: PAREVT)
20163 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20164 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20165 PARAMETER ( NALLWP = 39 )
20166 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20167 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20168 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20169 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20170 * (original name: NUCOLD)
20171 COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20172 & EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20178 APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20179 AMNUCL (1) = AMPROT
20180 AMNUCL (2) = AMNEUT
20181 AMNUSQ (1) = AMPROT * AMPROT
20182 AMNUSQ (2) = AMNEUT * AMNEUT
20183 AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20185 * ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20186 AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20187 AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20188 & ( 5.6D+00 * ASQHLP ) )
20189 AV0WEL = AEFRMX + EBNDAV
20190 EBNDNG (1) = EBNDAV
20191 EBNDNG (2) = EBNDAV
20192 AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20193 CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20194 AMMC12 = 12.D+00 * AMUGEV + AEXC12
20195 AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20196 AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20197 CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20198 AMMO16 = 16.D+00 * AMUGEV + AEXO16
20199 AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20200 AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20201 CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20202 AMMS28 = 28.D+00 * AMUGEV + AEXS28
20203 AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20204 AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20205 CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20206 AMMC40 = 40.D+00 * AMUGEV + AEXC40
20207 AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20208 AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20209 CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20210 AMMF56 = 56.D+00 * AMUGEV + AEXF56
20211 AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20212 AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20213 CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20214 AMM107 = 107.D+00 * AMUGEV + AEX107
20215 AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20216 AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20217 CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20218 AMM132 = 132.D+00 * AMUGEV + AEX132
20219 AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20220 AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20221 CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20222 AMM181 = 181.D+00 * AMUGEV + AEX181
20223 AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20224 AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20225 CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20226 AMM208 = 208.D+00 * AMUGEV + AEX208
20227 AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20228 AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20229 CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20230 AMM238 = 238.D+00 * AMUGEV + AEX238
20231 AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20233 AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20234 AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20235 AMHEAV (3) = TWOTWO * AMUGEV
20236 & + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20237 AMHEAV (4) = THRTHR * AMUGEV
20238 & + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20239 AMHEAV (5) = THRTHR * AMUGEV
20240 & + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20241 AMHEAV (6) = FOUFOU * AMUGEV
20242 & + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20243 ELBNDE (0) = ZERZER
20244 ELBNDE (1) = 13.6D-09
20245 DO 2000 IZ = 2, 100
20246 ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
20248 AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20249 AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20250 AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20251 AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20252 AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20253 AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20255 WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20256 & ' activated **** '
20257 IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20258 & ' production activated **** '
20260 * commented, since obsolete
20261 C IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20262 C & ' transport activated **** '
20263 IF ( IFISS .GT. 0 )
20264 & WRITE ( LUNOUT, * )' **** High Energy fission ',
20265 & ' requested & activated **** '
20267 & WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20268 & ' requested & activated **** '
20269 IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20277 *=== End of subroutine incini =========================================*
20280 *$ CREATE DT_STALIN.FOR
20283 *=== stalin ===========================================================*
20285 SUBROUTINE DT_STALIN
20287 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20289 PARAMETER ( ANGLGB = 5.0D-16 )
20290 PARAMETER ( ZERZER = 0.D+00 )
20291 PARAMETER ( ONEONE = 1.D+00 )
20292 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20293 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20294 PARAMETER ( EMVGEV = 1.0 D-03 )
20295 PARAMETER ( NSTBIS = 304 )
20296 PARAMETER ( LUNIN = 5 )
20297 PARAMETER ( LUNOUT = 6 )
20299 *----------------------------------------------------------------------*
20301 * STAbility LINe calculation: *
20303 * Created on 04 december 1992 by Alfredo Ferrari & Paola Sala *
20306 * Last change on 04-dec-92 by Alfredo Ferrari *
20309 *----------------------------------------------------------------------*
20311 * (original name: ISOTOP)
20312 PARAMETER ( NAMSMX = 270 )
20313 PARAMETER ( NZGVAX = 15 )
20314 PARAMETER ( NISMMX = 574 )
20315 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20316 & WAPISM (NISMMX), T12ISM (NISMMX),
20317 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20318 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20319 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20320 & INWAPS (NAMSMX), JSPISM (NISMMX),
20321 & JPTISM (NISMMX), IZWISM (NISMMX),
20322 & INWISM (0:NAMSMX)
20324 DIMENSION ZNORM (260)
20325 * +-------------------------------------------------------------------*
20329 ASTLIN (J,IZ) = ZERZER
20333 * +-------------------------------------------------------------------*
20334 * +-------------------------------------------------------------------*
20337 ZNORM (IA) = ZERZER
20339 ZSTLIN (J,IA) = ZERZER
20343 * +-------------------------------------------------------------------*
20344 * +-------------------------------------------------------------------*
20345 * | Loop on the Atomic Number
20347 AMSSST (IZ) = ZERZER
20350 * | +----------------------------------------------------------------*
20351 * | | Loop on the stable isotopes
20352 DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20354 ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20355 ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20356 ZNORM (IA) = ZNORM (IA) + ABUISO (IS)
20357 ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20358 ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20360 IF ( AHELP .LE. 1.00001D+00 ) THEN
20361 ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20364 AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20365 & + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20368 * | +----------------------------------------------------------------*
20369 AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20370 * | Normalize and print A_stab versus Z data:
20371 ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20373 * WRITE (LUNOUT,*)' Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20374 * & ' Sigma_st',SNGL(ASTLIN(2,IZ))
20377 * +-------------------------------------------------------------------*
20378 * +-------------------------------------------------------------------*
20379 * | Normalize and print Z_stab versus A data:
20381 ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20382 ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20383 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20384 IF ( ZNORM (IA) .GT. ANGLGB )
20385 **sr 2.11. avoid underflows at Pentium
20387 & MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20388 C & ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20392 * +-------------------------------------------------------------------*
20393 * +-------------------------------------------------------------------*
20394 * | Normalize and print Z_stab versus A data:
20396 IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20397 DO 4200 JA = IA-1,1,-1
20398 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20404 DO 4400 JA = IA+1,260
20405 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20413 ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20414 & * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20416 ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20417 & * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20420 IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20421 ATOZ = IZ / ASTLIN (1,IZ)
20422 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20423 * WRITE (LUNOUT,*)' A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20424 * & ' Sigma_st',SNGL(ZSTLIN(2,IA))
20427 * +-------------------------------------------------------------------*
20431 *$ CREATE DT_BERTTP.FOR
20434 *=== berttp ===========================================================*
20436 SUBROUTINE DT_BERTTP
20438 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20441 PARAMETER ( CSNNRM = 2.0D-15 )
20442 PARAMETER ( ZERZER = 0.D+00 )
20443 PARAMETER ( ONEONE = 1.D+00 )
20444 PARAMETER ( THRTHR = 3.D+00 )
20445 PARAMETER ( SIXSIX = 6.D+00 )
20446 PARAMETER ( ONETHI = ONEONE / THRTHR )
20447 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20448 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20449 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20450 PARAMETER ( EMVGEV = 1.0 D-03 )
20452 PARAMETER ( NSTBIS = 304 )
20454 PARAMETER ( LUNIN = 5 )
20455 PARAMETER ( LUNOUT = 6 )
20456 **sr 19.5. set error output-unit from 15 to 6
20457 PARAMETER ( LUNERR = 6 )
20458 C---------------------------------------------------------------------
20459 C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20460 C---------------------------------------------------------------------
20461 C ---------------------------------- I-N-C DATA
20462 C COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20463 C REAL*8 R8,R8B,CRSC,CS
20465 C --------------------------------- EVAPORATION DATA
20466 * (original name: COOKCM)
20467 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20468 LOGICAL LDEFOZ, LDEFON
20469 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20470 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20471 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20472 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20473 * (original name: EVA0)
20474 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20475 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20476 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20477 * T (4,7), RMASS (297), ALPH (297), BET (297),
20478 * APRIME (250), IA (6), IZ (6)
20479 * (original name: FRBKCM)
20480 PARAMETER ( MXFFBK = 6 )
20481 PARAMETER ( MXZFBK = 9 )
20482 PARAMETER ( MXNFBK = 10 )
20483 PARAMETER ( MXAFBK = 16 )
20484 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20485 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20486 PARAMETER ( NXAFBK = MXAFBK + 1 )
20487 PARAMETER ( MXPSST = 300 )
20488 PARAMETER ( MXPSFB = 41000 )
20489 LOGICAL LFRMBK, LNCMSS
20490 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20491 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20492 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20493 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20494 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20495 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20496 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20497 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20498 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20499 * (original name: HETTP)
20500 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
20501 * (original name: INPFLG)
20502 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20503 * (original name: ISOTOP)
20504 PARAMETER ( NAMSMX = 270 )
20505 PARAMETER ( NZGVAX = 15 )
20506 PARAMETER ( NISMMX = 574 )
20507 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20508 & WAPISM (NISMMX), T12ISM (NISMMX),
20509 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20510 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20511 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20512 & INWAPS (NAMSMX), JSPISM (NISMMX),
20513 & JPTISM (NISMMX), IZWISM (NISMMX),
20514 & INWISM (0:NAMSMX)
20515 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20516 PARAMETER ( PI = PIPIPI )
20517 PARAMETER ( PISQ = PIPISQ )
20518 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20519 PARAMETER ( RZNUCL = 1.12 D+00 )
20520 PARAMETER ( RMSPRO = 0.8 D+00 )
20521 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
20522 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20524 PARAMETER ( RLLE04 = RZNUCL )
20525 PARAMETER ( RLLE16 = RZNUCL )
20526 PARAMETER ( RLGT16 = RZNUCL )
20527 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20528 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20529 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20530 PARAMETER ( SKLE04 = 1.4D+00 )
20531 PARAMETER ( SKLE16 = 1.9D+00 )
20532 PARAMETER ( SKGT16 = 2.4D+00 )
20533 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20534 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20535 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20536 PARAMETER ( ALPHA0 = 0.1D+00 )
20537 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20538 PARAMETER ( GAMSK0 = 0.9D+00 )
20539 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20540 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20541 PARAMETER ( POTBA0 = 1.D+00 )
20542 PARAMETER ( PNFRAT = 1.533D+00 )
20543 PARAMETER ( RADPIM = 0.035D+00 )
20544 PARAMETER ( RDPMHL = 14.D+00 )
20545 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20546 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20547 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20548 PARAMETER ( AP0PFS = 0.5D+00 )
20549 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20550 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20551 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20552 PARAMETER ( MXSCIN = 50 )
20553 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20554 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20555 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20556 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20557 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20558 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20560 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20561 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20562 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20563 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20564 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20565 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20566 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20567 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20568 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20569 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20570 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20571 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20572 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20573 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20574 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20575 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20576 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20577 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20578 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20579 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20580 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20581 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20582 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20583 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20584 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20585 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
20586 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20587 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20588 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20589 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20590 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20591 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20592 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20593 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20594 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20595 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20596 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20597 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20598 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20599 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20601 DIMENSION AWSTAB (2:260), SIGMAB (3)
20602 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20603 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20604 EQUIVALENCE ( RHOIPP, RHONCP (1) )
20605 EQUIVALENCE ( RHOINP, RHONCP (2) )
20606 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20607 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20608 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20609 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20610 EQUIVALENCE ( RHOIPT, RHONCT (1) )
20611 EQUIVALENCE ( RHOINT, RHONCT (2) )
20612 EQUIVALENCE ( OMALHL, SK3PAR )
20613 EQUIVALENCE ( ALPHAL, HABPAR )
20614 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20615 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20616 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20617 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20618 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20619 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20620 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20621 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20622 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20623 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20624 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20625 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20626 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20627 * (original name: NUCLEV)
20628 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20629 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20630 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20631 & CUMRAD (0:160,2), RUSNUC (2),
20632 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20633 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20634 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20635 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20636 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20637 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20638 & LFLVSL, LRLVSL, LEQSBL
20639 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20640 & MGSSPR (19) , MGSSNE (25)
20641 EQUIVALENCE ( RUSNUC (1), RUSPRO )
20642 EQUIVALENCE ( RUSNUC (2), RUSNEU )
20643 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20644 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20645 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20646 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20647 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20648 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20649 EQUIVALENCE ( NTANUC (1), NTAPRO )
20650 EQUIVALENCE ( NTANUC (2), NTANEU )
20651 EQUIVALENCE ( NAVNUC (1), NAVPRO )
20652 EQUIVALENCE ( NAVNUC (2), NAVNEU )
20653 EQUIVALENCE ( NLSNUC (1), NLSPRO )
20654 EQUIVALENCE ( NLSNUC (2), NLSNEU )
20655 EQUIVALENCE ( NCONUC (1), NCOPRO )
20656 EQUIVALENCE ( NCONUC (2), NCONEU )
20657 EQUIVALENCE ( NSKNUC (1), NSKPRO )
20658 EQUIVALENCE ( NSKNUC (2), NSKNEU )
20659 EQUIVALENCE ( NHANUC (1), NHAPRO )
20660 EQUIVALENCE ( NHANUC (2), NHANEU )
20661 EQUIVALENCE ( NUSNUC (1), NUSPRO )
20662 EQUIVALENCE ( NUSNUC (2), NUSNEU )
20663 EQUIVALENCE ( NACNUC (1), NACPRO )
20664 EQUIVALENCE ( NACNUC (2), NACNEU )
20665 EQUIVALENCE ( JMXNUC (1), JMXPRO )
20666 EQUIVALENCE ( JMXNUC (2), JMXNEU )
20667 EQUIVALENCE ( MAGNUC (1), MAGPRO )
20668 EQUIVALENCE ( MAGNUC (2), MAGNEU )
20669 * (original name: PAREVT)
20670 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20671 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20672 PARAMETER ( NALLWP = 39 )
20673 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20674 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20675 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20676 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20677 * (original name: XSEPAR)
20678 COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20679 & DDNXSE (100), EENXSE (100), ZZNXSE (100),
20680 & EMNXSE (100), XMNXSE (100),
20681 & AAPXSE (100), BBPXSE (100), CCPXSE (100),
20682 & DDPXSE (100), EEPXSE (100), FFPXSE (100),
20683 & ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20685 C---------------------------------------------------------------------
20687 * modified for use in DPMJET
20688 C WRITE( LUNOUT,'(A,I2)')
20689 C & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20691 IF (LEVPRT) WRITE(LUNOUT,1000)
20692 1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20693 & /,12X,'------------------------------------',/)
20695 CPH OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
20698 *!!!! changed to be able to read the ASCII !!!!
20700 C A. Ferrari: first of all read isotopic data
20701 READ (NBERNW,*) ISONDX
20702 READ (NBERNW,*) ISOMNM
20703 READ (NBERNW,*) ABUISO
20704 C READ (NBERTP) ISONDX
20705 C READ (NBERTP) ISOMNM
20706 C READ (NBERTP) ABUISO
20708 C READ (NBERTP) (CRSC(J,I),J=1,600)
20709 C A. Ferrari: commented also the dummy read to save disk space
20713 C A. Ferrari: commented also the dummy read to save disk space
20715 C---------------------------------------------------------------------
20716 READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20717 READ (NBERNW,*) IA,IZ
20722 READ (NBERNW,*) RHO,OMEGA
20723 READ (NBERNW,*) EXMASS
20724 READ (NBERNW,*) CAM2
20725 READ (NBERNW,*) CAM3
20726 READ (NBERNW,*) CAM4
20727 READ (NBERNW,*) CAM5
20728 READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20732 READ (NBERNW,*) RMASS
20733 READ (NBERNW,*) ALPH
20734 READ (NBERNW,*) BET
20735 READ (NBERNW,*) INWAPS
20736 READ (NBERNW,*) WAPS
20737 READ (NBERNW,*) T12NUC
20738 READ (NBERNW,*) JSPNUC
20739 READ (NBERNW,*) JPTNUC
20740 READ (NBERNW,*) INWISM
20741 READ (NBERNW,*) IZWISM
20742 READ (NBERNW,*) WAPISM
20743 READ (NBERNW,*) T12ISM
20744 READ (NBERNW,*) JSPISM
20745 READ (NBERNW,*) JPTISM
20746 READ (NBERNW,*) APRIME
20748 &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20749 READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20750 IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20751 & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20753 & ' *** Inconsistent Nuclear Geometry data on file ***'
20756 READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20757 & EKATAB, PFATAB, PFRTAB
20758 READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20760 READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20761 & ZZPXSE, EMPXSE, XMPXSE
20762 * Data about Fermi-breakup:
20763 READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20764 IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20765 & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20766 WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20767 & ' in the Nuclear Data file ***'
20768 STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20770 READ (NBERNW,*) IFRBKN
20771 READ (NBERNW,*) IFRBKZ
20772 READ (NBERNW,*) IFBKSP
20773 READ (NBERNW,*) IFBKST
20774 READ (NBERNW,*) EEXFBK
20776 CLOSE (UNIT=NBERNW)
20778 C READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20779 C READ (NBERTP) IA,IZ
20784 C READ (NBERTP) RHO,OMEGA
20785 C READ (NBERTP) EXMASS
20786 C READ (NBERTP) CAM2
20787 C READ (NBERTP) CAM3
20788 C READ (NBERTP) CAM4
20789 C READ (NBERTP) CAM5
20790 C READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20794 C READ (NBERTP) RMASS
20795 C READ (NBERTP) ALPH
20796 C READ (NBERTP) BET
20797 C READ (NBERTP) INWAPS
20798 C READ (NBERTP) WAPS
20799 C READ (NBERTP) T12NUC
20800 C READ (NBERTP) JSPNUC
20801 C READ (NBERTP) JPTNUC
20802 C READ (NBERTP) INWISM
20803 C READ (NBERTP) IZWISM
20804 C READ (NBERTP) WAPISM
20805 C READ (NBERTP) T12ISM
20806 C READ (NBERTP) JSPISM
20807 C READ (NBERTP) JPTISM
20808 C READ (NBERTP) APRIME
20809 C WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20810 C READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20811 C IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20812 C & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20814 C & ' *** Inconsistent Nuclear Geometry data on file ***'
20817 C READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20818 C & EKATAB, PFATAB, PFRTAB
20819 C READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20821 C READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20822 C & ZZPXSE, EMPXSE, XMPXSE
20823 * Data about Fermi-breakup:
20824 C READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20825 C IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20826 C & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20827 C WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20828 C & ' in the Nuclear Data file ***'
20829 C STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20831 C READ (NBERTP) IFRBKN
20832 C READ (NBERTP) IFRBKZ
20833 C READ (NBERTP) IFBKSP
20834 C READ (NBERTP) IFBKST
20835 C READ (NBERTP) EEXFBK
20836 C CLOSE (UNIT=NBERTP)
20838 SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20841 SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20844 IF ( ILVMOD .LE. 0 ) THEN
20850 DO 300 JZ = 1, IZCOOK
20851 CAM4 (JZ) = PZCOOK (JZ)
20853 DO 400 JN = 1, INCOOK
20854 CAM5 (JN) = PNCOOK (JZ)
20860 IF ( ILVMOD .EQ. 1 ) THEN
20862 & ' **** Standard EVAP T=0 level density used ****'
20863 ELSE IF ( ILVMOD .EQ. 2 ) THEN
20865 & ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20866 ELSE IF ( ILVMOD .EQ. 3 ) THEN
20868 & ' **** Julich A-dependent level density used ****'
20869 ELSE IF ( ILVMOD .EQ. 4 ) THEN
20871 & ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20875 & ' **** Unknown T=0 level density option requested ****'
20876 STOP 'BERTTP-ILVMOD'
20878 IF ( JLVMOD .LE. 0 ) THEN
20881 & ' **** No Excitation en. dependence for level densities ****'
20882 ELSE IF ( JLVMOD .EQ. 1 ) THEN
20884 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20886 & ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20892 ELSE IF ( JLVMOD .EQ. 2 ) THEN
20894 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20896 & ' **** with UNKNOWN set of parameters for T=oo ****'
20897 STOP 'BERTTP-JLVMOD'
20898 ELSE IF ( JLVMOD .EQ. 3 ) THEN
20900 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20902 & ' **** with UNKNOWN set of parameters for T=oo ****'
20903 STOP 'BERTTP-JLVMOD'
20904 ELSE IF ( JLVMOD .EQ. 4 ) THEN
20906 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20908 & ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20914 ELSE IF ( JLVMOD .EQ. 5 ) THEN
20916 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20918 & ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20923 ELSE IF ( JLVMOD .EQ. 6 ) THEN
20925 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20927 & ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20932 ELSE IF ( JLVMOD .EQ. 7 ) THEN
20934 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20936 & ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20941 ELSE IF ( JLVMOD .EQ. 8 ) THEN
20943 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20945 & ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20952 & ' **** Unknown T=oo level density option requested ****'
20953 STOP 'BERTTP-JLVMOD'
20957 & ' **** Cook''s modified pairing energy used ****'
20960 & ' **** Original Gilbert/Cameron pairing energy used ****'
20967 PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20970 PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20975 *$ CREATE DT_EVEVAP.FOR
20978 *====evevap============================================================*
20980 SUBROUTINE DT_EVEVAP(WE)
20982 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20984 PARAMETER ( LINP = 10 ,
20988 * flags for input different options
20989 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20990 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20991 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20998 *$ CREATE DT_FRBKIN.FOR
21001 *====frbkin============================================================*
21003 SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
21005 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21007 PARAMETER ( LINP = 10 ,
21011 LOGICAL LDUM1,LDUM2
21016 *$ CREATE DT_EXPLOD.FOR
21019 *=== explod ===========================================================*
21021 SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
21024 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21027 DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21028 & ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21033 ************************************************************************
21035 * DPMJET 3.0: cross section routines *
21037 ************************************************************************
21040 * SUBROUTINE DT_SHNDIF
21041 * diffractive cross sections (all energies)
21042 * SUBROUTINE DT_PHOXS
21043 * total and inel. cross sections from PHOJET interpol. tables
21044 * SUBROUTINE DT_XSHN
21045 * total and el. cross sections for all energies
21046 * SUBROUTINE DT_SIHNAB
21047 * pion 2-nucleon absorption cross sections
21048 * SUBROUTINE DT_SIGEMU
21049 * cross section for target "compounds"
21050 * SUBROUTINE DT_SIGGA
21051 * photon nucleus cross sections
21052 * SUBROUTINE DT_SIGGAT
21053 * photon nucleus cross sections from tables
21054 * SUBROUTINE DT_SANO
21055 * anomalous hard photon-nucleon cross sections from tables
21056 * SUBROUTINE DT_SIGGP
21057 * photon nucleon cross sections
21058 * SUBROUTINE DT_SIGVEL
21059 * quasi-elastic vector meson prod. cross sections
21060 * DOUBLE PRECISION FUNCTION DT_SIGVP
21062 * DOUBLE PRECISION FUNCTION DT_RRM2
21063 * DOUBLE PRECISION FUNCTION DT_RM2
21064 * DOUBLE PRECISION FUNCTION DT_SAM2
21065 * SUBROUTINE DT_CKMT
21066 * SUBROUTINE DT_CKMTX
21067 * SUBROUTINE DT_PDF0
21068 * SUBROUTINE DT_CKMTQ0
21069 * SUBROUTINE DT_CKMTDE
21070 * SUBROUTINE DT_CKMTPR
21071 * FUNCTION DT_CKMTFF
21073 * SUBROUTINE DT_FLUINI
21074 * total nucleon cross section fluctuation treatment
21076 * SUBROUTINE DT_SIGTBL
21077 * pre-tabulation of low-energy elastic x-sec. using SIHNEL
21078 * SUBROUTINE DT_XSTABL
21082 *$ CREATE DT_SHNDIF.FOR
21085 *===shndif===============================================================*
21087 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21089 **********************************************************************
21090 * Single diffractive hadron-nucleon cross sections *
21091 * S.Roesler 14/1/93 *
21093 * The cross sections are calculated from extrapolated single *
21094 * diffractive antiproton-proton cross sections (DTUJET92) using *
21095 * scaling relations between total and single diffractive cross *
21097 **********************************************************************
21099 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21101 PARAMETER (ZERO=0.0D0)
21103 * particle properties (BAMJET index convention)
21105 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21106 & IICH(210),IIBAR(210),K1(210),K2(210)
21108 CSD1 = 4.201483727D0
21109 CSD4 = -0.4763103556D-02
21110 CSD5 = 0.4324148297D0
21112 CHMSD1 = 0.8519297242D0
21113 CHMSD4 = -0.1443076599D-01
21114 CHMSD5 = 0.4014954567D0
21116 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21117 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21119 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21120 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21121 FRAC = SHMSD/SDIAPP
21123 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21124 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21125 & 10, 10, 20, 20, 20) KPROJ
21128 *---------------------------- p - p , n - p , sigma0+- - p ,
21130 CSD1 = 6.004476070D0
21131 CSD4 = -0.1257784606D-03
21132 CSD5 = 0.2447335720D0
21133 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21134 SIGDIH = FRAC*SIGDIF
21141 C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21143 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21146 C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21147 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21149 SIGDIH = FRAC*SIGDIF
21153 *-------------------------- leptons..
21159 *$ CREATE DT_PHOXS.FOR
21162 *===phoxs================================================================*
21164 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21166 ************************************************************************
21167 * Total/inelastic proton-nucleon cross sections taken from PHOJET- *
21168 * interpolation tables. *
21169 * This version dated 05.11.97 is written by S. Roesler *
21170 ************************************************************************
21172 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21175 PARAMETER ( LINP = 10 ,
21178 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21179 PARAMETER (TWOPI = 6.283185307179586454D+00,
21181 & GEV2MB = 0.38938D0)
21184 DATA LFIRST /.TRUE./
21186 * nucleon-nucleon event-generator
21189 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21190 * particle properties (BAMJET index convention)
21192 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21193 & IICH(210),IIBAR(210),K1(210),K2(210)
21196 C PARAMETER (IEETAB=10)
21197 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21199 C energy-interpolation table
21201 PARAMETER ( IEETA2 = 20 )
21203 DOUBLE PRECISION SIGTAB,SIGECM
21204 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21207 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21208 WRITE(LOUT,*) MCGENE
21209 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21213 IF (ECM.LE.ZERO) THEN
21214 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21215 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21218 IF (MODE.EQ.1) THEN
21223 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21225 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
21226 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21232 IF(ECM.LE.SIGECM(IP,1)) THEN
21235 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21237 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21244 WRITE(LOUT,'(/1X,A,2E12.3)')
21245 & 'PHOXS: warning! energy above initialization limit (',
21246 & ECM,SIGECM(IP,ISIMAX)
21253 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21254 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21256 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21257 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21258 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21259 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21260 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21266 *$ CREATE DT_XSHN.FOR
21269 *===xshn===============================================================*
21271 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21273 ************************************************************************
21274 * Total and elastic hadron-nucleon cross section. *
21275 * Below 500GeV cross sections are based on the '98 data compilation *
21276 * of the PDG. At higher energies PHOJET results are used (patched to *
21277 * the low energy data at 500GeV). *
21278 * IP projectile index (BAMJET numbering scheme) *
21279 * (should be in the range 1..25) *
21280 * IT target index (BAMJET numbering scheme) *
21281 * (1 = proton, 8 = neutron) *
21282 * PL laboratory momentum *
21283 * ECM cm. energy (ignored if PL>0) *
21284 * STOT total cross section *
21285 * SELA elastic cross section *
21286 * Last change: 24.4.99 by S. Roesler *
21287 ************************************************************************
21289 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21292 PARAMETER ( LINP = 10 ,
21295 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21297 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21298 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21299 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21302 * particle properties (BAMJET index convention)
21304 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21305 & IICH(210),IIBAR(210),K1(210),K2(210)
21306 * nucleon-nucleon event-generator
21309 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21311 C PARAMETER (IEETAB=10)
21312 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21314 C energy-interpolation table
21316 PARAMETER ( IEETA2 = 20 )
21318 DOUBLE PRECISION SIGTAB,SIGECM
21319 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21321 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21322 DIMENSION IDXDAT(25,2)
21325 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21326 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21327 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21328 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21329 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21330 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21331 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21333 * total cross sections:
21335 DATA (ASIGTO(1,K),K=1,NPOINT) /
21336 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21337 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21338 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21339 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21340 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21341 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21342 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21344 DATA (ASIGTO(2,K),K=1,NPOINT) /
21345 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21346 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21347 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21348 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21349 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21350 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21351 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21353 DATA (ASIGTO(3,K),K=1,NPOINT) /
21354 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21355 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21356 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21357 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21358 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21359 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21360 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21362 DATA (ASIGTO(4,K),K=1,NPOINT) /
21363 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21364 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21365 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21366 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21367 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21368 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21369 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21371 DATA (ASIGTO(5,K),K=1,NPOINT) /
21372 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21373 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21374 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21375 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21376 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21377 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21378 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21380 DATA (ASIGTO(6,K),K=1,NPOINT) /
21381 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21382 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21383 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21384 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21385 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21386 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21387 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21389 DATA (ASIGTO(7,K),K=1,NPOINT) /
21390 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21391 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21392 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21393 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21394 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21395 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21396 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21398 DATA (ASIGTO(8,K),K=1,NPOINT) /
21399 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21400 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21401 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21402 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21403 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21404 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21405 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21407 DATA (ASIGTO(9,K),K=1,NPOINT) /
21408 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21409 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21410 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21411 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21412 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21413 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21414 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21416 DATA (ASIGTO(10,K),K=1,NPOINT) /
21417 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21418 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21419 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21420 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21421 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21422 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21423 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21425 * elastic cross sections:
21427 DATA (ASIGEL(1,K),K=1,NPOINT) /
21428 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21429 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21430 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21431 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21432 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21433 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21434 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21436 DATA (ASIGEL(2,K),K=1,NPOINT) /
21437 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21438 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21439 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21440 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21441 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21442 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21443 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21445 DATA (ASIGEL(3,K),K=1,NPOINT) /
21446 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21447 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21448 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21449 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21450 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21451 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21452 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21454 DATA (ASIGEL(4,K),K=1,NPOINT) /
21455 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21456 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21457 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21458 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21459 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21460 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21461 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21463 DATA (ASIGEL(5,K),K=1,NPOINT) /
21464 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21465 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21466 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21467 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21468 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21469 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21470 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21472 DATA (ASIGEL(6,K),K=1,NPOINT) /
21473 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21474 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21475 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21476 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21477 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21478 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21479 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21481 DATA (ASIGEL(7,K),K=1,NPOINT) /
21482 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21483 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21484 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21485 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21486 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21487 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21488 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21490 DATA (ASIGEL(8,K),K=1,NPOINT) /
21491 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21492 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21493 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21494 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21495 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21496 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21497 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21499 DATA (ASIGEL(9,K),K=1,NPOINT) /
21500 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21501 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21502 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21503 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21504 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21505 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21506 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21508 DATA (ASIGEL(10,K),K=1,NPOINT) /
21509 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21510 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21511 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21512 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21513 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21514 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21515 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21517 DATA (IDXDAT(K,1),K=1,25) /
21518 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21520 DATA (IDXDAT(K,2),K=1,25) /
21521 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21524 DATA LFIRST /.TRUE./
21527 APLABL = LOG10(PLABLO)
21528 APLABH = LOG10(PLABHI)
21529 APTHRE = LOG10(PTHRE)
21530 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21531 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21534 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21535 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21536 IF (MCGENE.EQ.2) THEN
21537 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21538 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21540 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21543 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21545 PHOSEL = PHOSTO-PHOSIN
21546 APHOST = LOG10(PHOSTO)
21547 APHOSE = LOG10(PHOSEL)
21554 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21555 WRITE(LOUT,1000) IP,IT
21556 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21557 & 'proj/target',2I4)
21561 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21562 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21563 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21564 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21565 WRITE(LOUT,1001) PLAB,ECMS
21566 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21570 * index of spectrum
21573 IF (AAM(IP).GT.ZERO) THEN
21574 IF (ABS(IIBAR(IP)).GT.0) THEN
21584 IF (IT.EQ.8) IDXT = 2
21585 IDXS = IDXDAT(IDXP,IDXT)
21586 IF (IDXS.EQ.0) RETURN
21588 * compute momentum bin indices
21589 IF (PLAB.LT.PLABLO) THEN
21592 ELSEIF (PLAB.GE.PLABHI) THEN
21596 APLAB = LOG10(PLAB)
21597 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21598 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21599 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21600 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21605 * interpolate cross section
21606 IF (IDXS.GT.10) THEN
21608 IDXS2 = IDXS-10*IDXS1
21609 IF (IDX0.EQ.IDX1) THEN
21610 IF (IDX0.EQ.1) THEN
21611 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21612 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21615 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21616 PHOSEL = PHOSTO-PHOSIN
21617 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21618 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21619 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21620 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21621 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21622 ASELA = 0.5D0*(ASELA1+ASELA2)
21625 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21626 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21627 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21628 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21629 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21630 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21631 ASELA1 = ASIGEL(IDXS1,IDX0)+
21632 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21633 ASELA2 = ASIGEL(IDXS2,IDX0)+
21634 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21635 ASELA = 0.5D0*(ASELA1+ASELA2)
21638 IF (IDX0.EQ.IDX1) THEN
21639 IF (IDX0.EQ.1) THEN
21640 ASTOT = ASIGTO(IDXS,IDX0)
21641 ASELA = ASIGEL(IDXS,IDX0)
21644 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21645 PHOSEL = PHOSTO-PHOSIN
21646 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21647 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21650 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21651 ASTOT = ASIGTO(IDXS,IDX0)+
21652 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21653 ASELA = ASIGEL(IDXS,IDX0)+
21654 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21657 STOT = 10.0D0**ASTOT
21658 SELA = 10.0D0**ASELA
21663 *$ CREATE DT_SIHNAB.FOR
21666 *===sihnab===============================================================*
21668 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21670 **********************************************************************
21671 * Pion 2-nucleon absorption cross sections. *
21672 * (sigma_tot for pi+ d --> p p, pi- d --> n n *
21673 * taken from Ritchie PRC 28 (1983) 926 ) *
21674 * This version dated 18.05.96 is written by S. Roesler *
21675 **********************************************************************
21677 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21679 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21680 PARAMETER (AMPR = 938.0D0,
21690 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21691 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21693 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21694 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21695 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21696 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21697 * approximate 3N-abs., I=1-abs. etc.
21698 SIGABS = SIGABS/0.40D0
21699 * pi0-absorption (rough approximation!!)
21700 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21705 *$ CREATE DT_SIGEMU.FOR
21708 *===sigemu=============================================================*
21710 SUBROUTINE DT_SIGEMU
21712 ************************************************************************
21713 * Combined cross section for target compounds. *
21714 * This version dated 6.4.98 is written by S. Roesler *
21715 ************************************************************************
21717 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21719 PARAMETER ( LINP = 10 ,
21722 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21723 & OHALF=0.5D0,ONE=1.0D0)
21725 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21726 * Glauber formalism: cross sections
21727 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21728 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21729 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21730 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21731 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21732 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21733 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21734 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21735 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21736 & BSLOPE,NEBINI,NQBINI
21737 * emulsion treatment
21738 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21740 * nucleon-nucleon event-generator
21743 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21745 IF (MCGENE.NE.4) THEN
21746 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21747 WRITE(LOUT,'(15X,A)') '-----------------------'
21767 IF (NCOMPO.GT.0) THEN
21769 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21770 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21771 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21772 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21773 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21774 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21775 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21776 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21777 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21778 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21779 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21780 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21781 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21782 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21783 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21784 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21786 ERRTOT = SQRT(ERRTOT)
21787 ERRELA = SQRT(ERRELA)
21788 ERRQEP = SQRT(ERRQEP)
21789 ERRQET = SQRT(ERRQET)
21790 ERRQE2 = SQRT(ERRQE2)
21791 ERRPRO = SQRT(ERRPRO)
21792 ERRDEL = SQRT(ERRDEL)
21793 ERRDQE = SQRT(ERRDQE)
21795 SIGTOT = XSTOT(IE,IQ,1)
21796 SIGELA = XSELA(IE,IQ,1)
21797 SIGQEP = XSQEP(IE,IQ,1)
21798 SIGQET = XSQET(IE,IQ,1)
21799 SIGQE2 = XSQE2(IE,IQ,1)
21800 SIGPRO = XSPRO(IE,IQ,1)
21801 SIGDEL = XSDEL(IE,IQ,1)
21802 SIGDQE = XSDQE(IE,IQ,1)
21803 ERRTOT = XETOT(IE,IQ,1)
21804 ERRELA = XEELA(IE,IQ,1)
21805 ERRQEP = XEQEP(IE,IQ,1)
21806 ERRQET = XEQET(IE,IQ,1)
21807 ERRQE2 = XEQE2(IE,IQ,1)
21808 ERRPRO = XEPRO(IE,IQ,1)
21809 ERRDEL = XEDEL(IE,IQ,1)
21810 ERRDQE = XEDQE(IE,IQ,1)
21812 IF (MCGENE.NE.4) THEN
21813 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21814 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21815 WRITE(LOUT,1001) SIGTOT,ERRTOT
21816 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21817 WRITE(LOUT,1002) SIGELA,ERRELA
21818 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21819 WRITE(LOUT,1003) SIGQEP,ERRQEP
21820 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21822 WRITE(LOUT,1004) SIGQET,ERRQET
21823 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21825 WRITE(LOUT,1005) SIGQE2,ERRQE2
21826 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21827 & ' +-',F11.5,' mb')
21828 WRITE(LOUT,1006) SIGPRO,ERRPRO
21829 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21830 WRITE(LOUT,1007) SIGDEL,ERRDEL
21831 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21832 WRITE(LOUT,1008) SIGDQE,ERRDQE
21833 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21842 *$ CREATE DT_SIGGA.FOR
21845 *===sigga==============================================================*
21847 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21849 ************************************************************************
21850 * Total/inelastic photon-nucleus cross sections. *
21851 * !!!! Overwrites SHMAKI-initialization. Do not use it during *
21852 * production runs !!!! *
21853 * This version dated 27.03.96 is written by S. Roesler *
21854 ************************************************************************
21856 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21858 PARAMETER ( LINP = 10 ,
21861 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21862 & OHALF=0.5D0,ONE=1.0D0)
21863 PARAMETER (AMPROT = 0.938D0)
21865 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21866 * Glauber formalism: cross sections
21867 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21868 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21869 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21870 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21871 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21872 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21873 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21874 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21875 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21876 & BSLOPE,NEBINI,NQBINI
21883 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21884 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21885 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21886 STOT = XSTOT(1,1,1)
21887 ETOT = XETOT(1,1,1)
21894 *$ CREATE DT_SIGGAT.FOR
21897 *===siggat=============================================================*
21899 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21901 ************************************************************************
21902 * Total/inelastic photon-nucleus cross sections. *
21903 * Uses pre-tabulated cross section. *
21904 * This version dated 29.07.96 is written by S. Roesler *
21905 ************************************************************************
21907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21909 PARAMETER ( LINP = 10 ,
21912 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21913 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21915 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21916 * Glauber formalism: cross sections
21917 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21918 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21919 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21920 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21921 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21922 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21923 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21924 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21925 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21926 & BSLOPE,NEBINI,NQBINI
21932 IF (NEBINI.GT.1) THEN
21933 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21937 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21939 IF (ECMI.LT.ECMNN(I)) THEN
21942 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21952 IF (NQBINI.GT.1) THEN
21953 IF (Q2I.GE.Q2G(NQBINI)) THEN
21957 ELSEIF (Q2I.GT.Q2G(1)) THEN
21959 IF (Q2I.LT.Q2G(I)) THEN
21962 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21963 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21964 C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21972 STOT = XSTOT(I1,J1,NTARG)+
21973 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21974 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21975 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21976 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21981 *$ CREATE DT_SANO.FOR
21984 *===sigano=============================================================*
21986 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21988 ************************************************************************
21989 * This version dated 31.07.96 is written by S. Roesler *
21990 ************************************************************************
21992 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21994 PARAMETER ( LINP = 10 ,
21997 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21998 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
22001 * VDM parameter for photon-nucleus interactions
22002 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22003 * properties of interacting particles
22004 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
22006 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
22008 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
22009 & 0.100D+04,0.200D+04,0.500D+04
22011 * fixed cut (3 GeV/c)
22013 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
22014 & 0.062D+00,0.054D+00,0.042D+00
22017 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
22018 & 3.3086D-01,7.6255D-01,2.1319D+00
22020 * running cut (based on obsolete Phojet-caluclations, bugs..)
22022 C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
22023 C & 0.167E+00,0.150E+00,0.131E+00
22026 C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22027 C & 2.5736E-01,4.5593E-01,8.2550E-01
22031 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22035 IF (ECM.GE.ECMANO(NE)) THEN
22038 ELSEIF (ECM.GT.ECMANO(1)) THEN
22040 IF (ECM.LT.ECMANO(IE)) THEN
22043 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22049 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22050 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22051 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22052 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22058 *$ CREATE DT_SIGGP.FOR
22061 *===siggp==============================================================*
22063 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22065 ************************************************************************
22066 * Total/inelastic photon-nucleon cross sections. *
22067 * This version dated 30.04.96 is written by S. Roesler *
22068 ************************************************************************
22070 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22072 PARAMETER ( LINP = 10 ,
22075 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22076 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22078 & GEV2MB = 0.38938D0,
22079 & ALPHEM = ONE/137.0D0)
22081 * particle properties (BAMJET index convention)
22083 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22084 & IICH(210),IIBAR(210),K1(210),K2(210)
22085 * VDM parameter for photon-nucleus interactions
22086 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22089 C CHARACTER*8 MDLNA
22090 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22091 C PARAMETER (IEETAB=10)
22092 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22094 C model switches and parameters
22096 INTEGER ISWMDL,IPAMDL
22097 DOUBLE PRECISION PARMDL
22098 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22099 C energy-interpolation table
22101 PARAMETER ( IEETA2 = 20 )
22103 DOUBLE PRECISION SIGTAB,SIGECM
22104 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22107 C PARAMETER (NPOINT=80)
22108 PARAMETER (NPOINT=16)
22109 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22116 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22117 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22121 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22123 X = Q2/(W2+Q2-AAM(1)**2)
22125 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22126 X = Q2/(W2+Q2-AAM(1)**2)
22127 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22128 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22129 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22130 W2 = Q2*(ONE-X)/X+AAM(1)**2
22132 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22137 IF (MODEGA.EQ.1) THEN
22139 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22142 C ALLMF2 = PHO_ALLM97(Q2,W)
22143 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22144 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22147 ELSEIF (MODEGA.EQ.2) THEN
22148 IF (INTRGE(1).EQ.1) THEN
22149 AMLO2 = (3.0D0*AAM(13))**2
22150 ELSEIF (INTRGE(1).EQ.2) THEN
22155 IF (INTRGE(2).EQ.1) THEN
22157 ELSEIF (INTRGE(2).EQ.2) THEN
22162 AMHI20 = (ECM-AAM(1))**2
22163 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22164 XAMLO = LOG( AMLO2+Q2 )
22165 XAMHI = LOG( AMHI2+Q2 )
22167 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22169 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22173 AM2 = EXP(ABSZX(J))-Q2
22174 IF (AM2.LT.16.0D0) THEN
22176 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22181 C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22182 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22183 & * (ONE+EPSPOL*Q2/AM2)
22184 SUM = SUM+WEIGHT(J)*FAC
22187 SDIR = DT_SIGVP(X,Q2)
22188 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22189 SDIR = SDIR/(0.588D0+RL2+Q2)
22190 C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22191 ELSEIF (MODEGA.EQ.3) THEN
22192 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22193 ELSEIF (MODEGA.EQ.4) THEN
22194 * load cross sections from PHOJET interpolation table
22196 IF(ECM.LE.SIGECM(IP,1)) THEN
22199 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22201 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22207 WRITE(LOUT,'(/1X,A,2E12.3)')
22208 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22213 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22214 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22216 * cross section dependence on photon virtuality
22219 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22220 & /(1.D0+Q2/PARMDL(30+I))**2
22222 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22226 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22227 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22228 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22232 SDIR = SDIR/(FSUP1*FSUP2)
22241 *$ CREATE DT_SIGVEL.FOR
22244 *===sigvel=============================================================*
22246 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22248 ************************************************************************
22249 * Cross section for elastic vector meson production *
22250 * This version dated 10.05.96 is written by S. Roesler *
22251 ************************************************************************
22253 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22255 PARAMETER ( LINP = 10 ,
22258 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22259 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22261 & GEV2MB = 0.38938D0,
22262 & ALPHEM = ONE/137.0D0)
22264 * particle properties (BAMJET index convention)
22266 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22267 & IICH(210),IIBAR(210),K1(210),K2(210)
22268 * VDM parameter for photon-nucleus interactions
22269 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22272 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22273 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22277 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22279 X = Q2/(W2+Q2-AAM(1)**2)
22281 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22282 X = Q2/(W2+Q2-AAM(1)**2)
22283 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22284 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22285 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22286 W2 = Q2*(ONE-X)/X+AAM(1)**2
22288 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22296 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22297 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22299 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22300 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22302 IF (IDXV.EQ.33) THEN
22307 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22309 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
22310 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
22315 *$ CREATE DT_SIGVP.FOR
22318 *===sigvp==============================================================*
22320 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22322 ************************************************************************
22324 ************************************************************************
22326 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22329 PARAMETER ( LINP = 10 ,
22332 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22333 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22335 & GEV2MB = 0.38938D0,
22336 & AMPROT = 0.938D0,
22337 & ALPHEM = ONE/137.0D0)
22338 * VDM parameter for photon-nucleus interactions
22339 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22343 IF (XI.LE.ZERO) X = 0.0001D0
22344 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22346 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22349 IF (MODEGA.EQ.1) THEN
22350 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22353 C ALLMF2 = PHO_ALLM97(Q2,W)
22354 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22355 C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22356 C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22357 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22358 ELSEIF (MODEGA.EQ.4) THEN
22359 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22360 C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22361 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22363 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22370 *$ CREATE DT_RRM2.FOR
22373 *===RRM2===============================================================*
22375 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22377 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22379 PARAMETER ( LINP = 10 ,
22382 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22383 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22385 & GEV2MB = 0.38938D0)
22387 * particle properties (BAMJET index convention)
22389 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22390 & IICH(210),IIBAR(210),K1(210),K2(210)
22391 * VDM parameter for photon-nucleus interactions
22392 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22394 S = Q2*(ONE-X)/X+AAM(1)**2
22397 IF (INTRGE(1).EQ.1) THEN
22398 AMLO2 = (3.0D0*AAM(13))**2
22399 ELSEIF (INTRGE(1).EQ.2) THEN
22404 IF (INTRGE(2).EQ.1) THEN
22406 ELSEIF (INTRGE(2).EQ.2) THEN
22411 AMHI20 = (ECM-AAM(1))**2
22412 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22416 IF (AMHI2.LE.AM1C2) THEN
22417 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22418 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22419 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22420 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22422 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22423 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22424 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22430 *$ CREATE DT_RM2.FOR
22433 *===RM2================================================================*
22435 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22437 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22439 PARAMETER ( LINP = 10 ,
22442 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22443 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22445 & GEV2MB = 0.38938D0)
22446 * VDM parameter for photon-nucleus interactions
22447 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22449 IF (RL2.LE.ZERO) THEN
22450 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22451 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22452 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22454 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22455 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22456 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22457 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22459 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22460 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22466 *$ CREATE DT_SAM2.FOR
22469 *===SAM2===============================================================*
22471 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22473 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22475 PARAMETER ( LINP = 10 ,
22478 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22479 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22480 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22482 & GEV2MB = 0.38938D0)
22484 * particle properties (BAMJET index convention)
22486 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22487 & IICH(210),IIBAR(210),K1(210),K2(210)
22488 * VDM parameter for photon-nucleus interactions
22489 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22492 IF (INTRGE(1).EQ.1) THEN
22493 AMLO2 = (3.0D0*AAM(13))**2
22494 ELSEIF (INTRGE(1).EQ.2) THEN
22499 IF (INTRGE(2).EQ.1) THEN
22501 ELSEIF (INTRGE(2).EQ.2) THEN
22506 AMHI20 = (ECM-AAM(1))**2
22507 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22511 YLO = LOG(AMLO2+Q2)
22512 YC1 = LOG(AM1C2+Q2)
22513 YC2 = LOG(AM2C2+Q2)
22514 YHI = LOG(AMHI2+Q2)
22515 IF (AMHI2.LE.AM1C2) THEN
22517 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22524 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22525 IF (YSAM2.LE.YC1) THEN
22527 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22532 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22533 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22534 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22536 DT_SAM2 = EXP(YSAM2)-Q2
22541 *$ CREATE DT_CKMT.FOR
22544 *===ckmt===============================================================*
22546 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22549 ************************************************************************
22550 * This version dated 31.01.96 is written by S. Roesler *
22551 ************************************************************************
22553 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22555 PARAMETER ( LINP = 10 ,
22558 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22560 PARAMETER (Q02 = 2.0D0,
22564 DIMENSION PD(-6:6),SEA(3),VAL(2)
22566 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22567 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22568 ADQ2 = LOG10(Q12)-LOG10(Q02)
22569 F2P = (F2Q1-F2Q0)/ADQ2
22570 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22571 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22572 F2PP = (F2PQ1-F2PQ0)/ADQ2
22573 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22575 Q2 = MAX(SCALE**2.0D0,TINY10)
22576 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22577 IF (Q2.LT.Q02) THEN
22578 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22589 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22602 C USEA = USEA*SMOOTH
22603 C DSEA = DSEA*SMOOTH
22613 *$ CREATE DT_CKMTX.FOR
22615 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22616 C**********************************************************************
22618 C PDF based on Regge theory, evolved with .... by ....
22620 C input: IPAR 2212 proton (not installed)
22624 C output: PD(-6:6) x*f(x) parton distribution functions
22625 C (PDFLIB convention: d = PD(1), u = PD(2) )
22627 C**********************************************************************
22630 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22631 PARAMETER ( LINP = 10 ,
22639 C QCD lambda for evolution
22642 C Q0**2 for evolution
22646 C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22647 C q(6)=x*charm, q(7)=x*gluon
22651 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22653 IF(IPAR.EQ.2212) THEN
22654 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22655 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22656 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22657 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22658 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22659 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22660 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22661 C ELSEIF (IPAR.EQ.45) THEN
22662 C CALL CKMTPO(1,0,XX,SB,QQ(1))
22663 C CALL CKMTPO(2,0,XX,SB,QQ(2))
22664 C CALL CKMTPO(3,0,XX,SB,QQ(3))
22665 C CALL CKMTPO(4,0,XX,SB,QQ(4))
22666 C CALL CKMTPO(5,0,XX,SB,QQ(5))
22667 C CALL CKMTPO(8,0,XX,SB,QQ(6))
22668 C CALL CKMTPO(7,0,XX,SB,QQ(7))
22669 ELSEIF (IPAR.EQ.100) THEN
22670 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22671 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22672 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22673 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22674 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22675 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22676 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22678 WRITE(LOUT,'(1X,A,I4,A)')
22679 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22685 PD(-4) = DBLE(QQ(6))
22686 PD(-3) = DBLE(QQ(3))
22687 PD(-2) = DBLE(QQ(4))
22688 PD(-1) = DBLE(QQ(5))
22689 PD(0) = DBLE(QQ(7))
22690 PD(1) = DBLE(QQ(2))
22691 PD(2) = DBLE(QQ(1))
22692 PD(3) = DBLE(QQ(3))
22693 PD(4) = DBLE(QQ(6))
22696 IF(IPAR.EQ.45) THEN
22697 CDN = (PD(1)-PD(-1))/2.D0
22698 CUP = (PD(2)-PD(-2))/2.D0
22699 PD(-1) = PD(-1) + CDN
22700 PD(-2) = PD(-2) + CUP
22704 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22705 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22706 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22710 *$ CREATE DT_PDF0.FOR
22713 *===pdf0===============================================================*
22715 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22717 ************************************************************************
22718 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22719 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22720 * IPAR = 2212 proton *
22722 * This version dated 31.01.96 is written by S. Roesler *
22723 ************************************************************************
22725 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22727 PARAMETER ( LINP = 10 ,
22730 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22739 & DELTA0 = 0.07684D0,
22744 & ALPHAR = 0.415D0,
22748 PARAMETER (NPOINT=16)
22749 C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22750 DIMENSION SEA(3),VAL(2)
22752 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22753 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22755 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22756 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22757 SEA(1) = 0.75D0*SEA0
22760 VAL(1) = 9.0D0/4.0D0*VALU0
22761 VAL(2) = 9.0D0*VALD0
22762 GLU0 = SEA(1)/(1.0D0-X)
22763 F2 = SEA0+VALU0+VALD0
22764 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22765 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22766 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22767 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22768 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22772 C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22774 C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22779 C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22780 C VALU0 = 9.0D0/4.0D0*VALU0
22781 C VALD0 = 9.0D0*VALD0
22782 C SEA0 = 0.75D0*SEA0
22783 C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22784 C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22786 C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22788 WRITE(LOUT,'(1X,A,I4,A)')
22789 & 'PDF0: IPAR =',IPAR,' not implemented!'
22796 *$ CREATE DT_CKMTQ0.FOR
22799 *===ckmtq0=============================================================*
22801 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22803 ************************************************************************
22804 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22805 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22806 * IPAR = 2212 proton *
22808 * This version dated 31.01.96 is written by S. Roesler *
22809 ************************************************************************
22811 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22813 PARAMETER ( LINP = 10 ,
22816 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22825 & DELTA0 = 0.07684D0,
22830 & ALPHAR = 0.415D0,
22834 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22835 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22837 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22838 IF (IPAR.EQ.2212) THEN
22845 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22846 & (Q2/(Q2+A))**(1.0D0+DELTA)
22847 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22848 & (Q2/(Q2+B))**(ALPHAR)
22849 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22850 & (Q2/(Q2+B))**(ALPHAR)
22852 WRITE(LOUT,'(1X,A,I4,A)')
22853 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22861 *$ CREATE DT_CKMTDE.FOR
22863 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22865 C**********************************************************************
22867 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22869 C This version by S. Roesler, 30.01.96
22870 C**********************************************************************
22873 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22874 EQUIVALENCE (GF(1,1,1),DL(1))
22877 DATA (DL(K),K= 1, 85) /
22878 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22879 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22880 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22881 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22882 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22883 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22884 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22885 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22886 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22887 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22888 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22889 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22890 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22891 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22892 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22893 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22894 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22895 DATA (DL(K),K= 86, 170) /
22896 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22897 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22898 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22899 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22900 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22901 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22902 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22908 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22909 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22910 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22911 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22912 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22913 DATA (DL(K),K= 171, 255) /
22914 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22915 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22916 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22917 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22918 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22919 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22920 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22921 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22922 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22923 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22924 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22925 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22926 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22927 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22928 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22929 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22930 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22931 DATA (DL(K),K= 256, 340) /
22932 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22933 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22934 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22935 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22936 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22942 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22943 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22944 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22945 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22946 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22947 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22948 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22949 DATA (DL(K),K= 341, 425) /
22950 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22951 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22952 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22953 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22954 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22955 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22956 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22957 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22958 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22959 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22960 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22961 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22962 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22963 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22964 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22965 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22966 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22967 DATA (DL(K),K= 426, 510) /
22968 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22969 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22970 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22976 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22977 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22978 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22979 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22980 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22981 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22982 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22983 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22984 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22985 DATA (DL(K),K= 511, 595) /
22986 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22987 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22988 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22989 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22990 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22991 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22992 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22993 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22994 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22995 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22996 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22997 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22998 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22999 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
23000 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
23001 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
23002 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
23003 DATA (DL(K),K= 596, 680) /
23004 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23010 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23011 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23012 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23013 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23014 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
23015 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
23016 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
23017 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
23018 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
23019 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
23020 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
23021 DATA (DL(K),K= 681, 765) /
23022 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
23023 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
23024 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
23025 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
23026 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23027 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23028 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23029 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23030 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23031 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23032 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23033 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23034 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23035 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23036 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23037 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23038 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23039 DATA (DL(K),K= 766, 850) /
23040 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23041 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23042 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23043 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23044 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23045 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23046 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23047 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23048 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23049 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23050 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23051 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23052 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23053 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23054 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23055 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23056 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23057 DATA (DL(K),K= 851, 935) /
23058 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23059 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23060 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23061 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23062 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23063 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23064 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23065 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23066 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23067 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23068 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23069 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23070 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23071 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
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 DATA (DL(K),K= 936, 1020) /
23076 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23077 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23078 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23079 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23080 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23081 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23082 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23083 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23084 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23085 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23086 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23087 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23088 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23089 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23090 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23091 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23092 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23093 DATA (DL(K),K= 1021, 1105) /
23094 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23095 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23096 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23097 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23098 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23099 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23100 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23101 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23102 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23103 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23104 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23105 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
23106 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23107 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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 DATA (DL(K),K= 1106, 1190) /
23112 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23113 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23114 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23115 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23116 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23117 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23118 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23119 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23120 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23121 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23122 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23123 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23124 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23125 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23126 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23127 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23128 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23129 DATA (DL(K),K= 1191, 1275) /
23130 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23131 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23132 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23133 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23134 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23135 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23136 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23137 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23138 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23139 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23144 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23145 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23146 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23147 DATA (DL(K),K= 1276, 1360) /
23148 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23149 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23150 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23151 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23152 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23153 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23154 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23155 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23156 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23157 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23158 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23159 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23160 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23161 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23162 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23163 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23164 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23165 DATA (DL(K),K= 1361, 1445) /
23166 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23167 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23168 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23169 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23170 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23171 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23172 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23173 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23179 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23180 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23181 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23182 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23183 DATA (DL(K),K= 1446, 1530) /
23184 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23185 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23186 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23187 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23188 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23189 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23190 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23191 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23192 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23193 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23194 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23195 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23196 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23197 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23198 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23199 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23200 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23201 DATA (DL(K),K= 1531, 1615) /
23202 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23203 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23204 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23205 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23206 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23207 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23213 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23214 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23215 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23216 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23217 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23218 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23219 DATA (DL(K),K= 1616, 1700) /
23220 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23221 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23222 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23223 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23224 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23225 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23226 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23227 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23228 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23229 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23230 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23231 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23232 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23233 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23234 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23235 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23236 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23237 DATA (DL(K),K= 1701, 1785) /
23238 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23239 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23240 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23241 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23247 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23248 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23249 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23250 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23251 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23252 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23253 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23254 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23255 DATA (DL(K),K= 1786, 1870) /
23256 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23257 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23258 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23259 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23260 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23261 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23262 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23263 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23264 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23265 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23266 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23267 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23268 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23269 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23270 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23271 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23272 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23273 DATA (DL(K),K= 1871, 1955) /
23274 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23275 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23281 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23282 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23283 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23284 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23285 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23286 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23287 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23288 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23289 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23290 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23291 DATA (DL(K),K= 1956, 2040) /
23292 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23293 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23294 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23295 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23296 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23297 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23298 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23299 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23300 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23301 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23302 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23303 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23304 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23305 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23306 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23307 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23308 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23309 DATA (DL(K),K= 2041, 2125) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23315 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23316 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23317 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23318 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23319 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23320 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23321 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23322 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23323 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23324 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23325 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23326 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23327 DATA (DL(K),K= 2126, 2210) /
23328 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23329 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23330 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23331 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23332 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23333 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23334 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23335 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23336 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23337 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23338 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23339 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23340 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23341 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23342 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
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 DATA (DL(K),K= 2211, 2295) /
23346 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23347 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23348 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23349 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23350 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23351 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23352 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23353 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23354 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23355 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23356 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23357 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23358 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23359 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23360 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23361 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23362 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23363 DATA (DL(K),K= 2296, 2380) /
23364 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23365 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23366 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23367 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23368 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23369 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23370 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23371 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23372 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23373 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23374 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23375 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23376 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23377 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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 DATA (DL(K),K= 2381, 2465) /
23382 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23383 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23384 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23385 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23386 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23387 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23388 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23389 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23390 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23391 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23392 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23393 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23394 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23395 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23396 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23397 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23398 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23399 DATA (DL(K),K= 2466, 2550) /
23400 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23401 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23402 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23403 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23404 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23405 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23406 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23407 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23408 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23409 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23410 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23417 DATA (DL(K),K= 2551, 2635) /
23418 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23419 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23420 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23421 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23422 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23423 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23424 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23425 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23426 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23427 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23428 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23429 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23430 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23431 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23432 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23433 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23434 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23435 DATA (DL(K),K= 2636, 2720) /
23436 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23437 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23438 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23439 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23440 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23441 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23442 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23443 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23444 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23450 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23451 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23452 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23453 DATA (DL(K),K= 2721, 2805) /
23454 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23455 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23456 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23457 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23458 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23459 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23460 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23461 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23462 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23463 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23464 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23465 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23466 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23467 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23468 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23469 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23470 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23471 DATA (DL(K),K= 2806, 2890) /
23472 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23473 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23474 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23475 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23476 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23477 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23478 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23484 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23485 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23486 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23487 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23488 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23489 DATA (DL(K),K= 2891, 2975) /
23490 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23491 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23492 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23493 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23494 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23495 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23496 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23497 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23498 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23499 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23500 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23501 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23502 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23503 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23504 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23505 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23506 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23507 DATA (DL(K),K= 2976, 3060) /
23508 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23509 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23510 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23511 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23512 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23518 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23519 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23520 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23521 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23522 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23523 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23524 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23525 DATA (DL(K),K= 3061, 3145) /
23526 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23527 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23528 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23529 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23530 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23531 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23532 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23533 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23534 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23535 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23536 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23537 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23538 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23539 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23540 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23541 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23542 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23543 DATA (DL(K),K= 3146, 3230) /
23544 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23545 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23546 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23552 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23553 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23554 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23555 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23556 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23557 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23558 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23559 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23560 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23561 DATA (DL(K),K= 3231, 3315) /
23562 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23563 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23564 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23565 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23566 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23567 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23568 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23569 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23570 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23571 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23572 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23573 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23574 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23575 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23576 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23577 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23578 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23579 DATA (DL(K),K= 3316, 3400) /
23580 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23586 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23587 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23588 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23589 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23590 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23591 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23592 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23593 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23594 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23595 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23596 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23597 DATA (DL(K),K= 3401, 3485) /
23598 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23599 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23600 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23601 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23602 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23603 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23604 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23605 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23606 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23607 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23608 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23609 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23610 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23611 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23612 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23613 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23614 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23615 DATA (DL(K),K= 3486, 3570) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23620 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23621 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23622 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23623 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23624 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23625 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23626 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23627 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23628 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23629 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23630 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23631 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23632 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23633 DATA (DL(K),K= 3571, 3655) /
23634 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23635 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23636 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23637 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23638 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23639 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23640 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23641 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23642 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23643 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23644 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23645 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23646 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23647 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
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 DATA (DL(K),K= 3656, 3740) /
23652 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23653 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23654 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23655 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23656 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23657 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23658 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23659 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23660 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23661 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23662 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23663 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23664 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23665 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23666 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23667 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23668 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23669 DATA (DL(K),K= 3741, 3825) /
23670 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23671 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23672 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23673 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23674 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23675 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23676 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23677 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23678 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23679 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23680 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23681 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23682 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23683 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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 DATA (DL(K),K= 3826, 3910) /
23688 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23689 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23690 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23691 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23692 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23693 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23694 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23695 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23696 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23697 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23698 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23699 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23700 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23701 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23702 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23703 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23704 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23705 DATA (DL(K),K= 3911, 3995) /
23706 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23707 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23708 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23709 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23710 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23711 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23712 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23713 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23714 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23715 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23720 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23721 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23722 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23723 DATA (DL(K),K= 3996, 4000) /
23724 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23727 IF (X.GT.0.9985) RETURN
23728 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23734 F1(L) = GF(I,IS,KL)
23735 F2(L) = GF(I,IS1,KL)
23737 A1 = DT_CKMTFF(X,F1)
23738 A2 = DT_CKMTFF(X,F2)
23743 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23750 *$ CREATE DT_CKMTPR.FOR
23752 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23754 C**********************************************************************
23756 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23758 C This version by S. Roesler, 31.01.96
23759 C**********************************************************************
23762 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23763 EQUIVALENCE (GF(1,1,1),DL(1))
23766 DATA (DL(K),K= 1, 85) /
23767 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23768 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23769 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23770 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23771 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23772 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23773 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23774 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23775 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23776 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23777 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23778 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23779 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23780 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23781 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23782 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23783 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23784 DATA (DL(K),K= 86, 170) /
23785 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23786 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23787 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23788 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23789 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23790 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23791 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23792 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23793 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23794 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23795 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23796 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23797 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23798 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23799 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23800 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23801 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23802 DATA (DL(K),K= 171, 255) /
23803 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23804 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23805 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23806 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23807 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23808 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23809 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23810 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23811 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23812 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23813 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23814 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23815 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23816 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23817 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23818 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23819 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23820 DATA (DL(K),K= 256, 340) /
23821 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23822 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23823 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23824 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23825 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23826 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23827 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23828 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23829 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23830 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23831 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23832 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23833 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23834 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23835 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23836 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23837 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23838 DATA (DL(K),K= 341, 425) /
23839 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23840 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23841 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23842 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23843 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23844 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23845 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23846 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23847 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23848 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23849 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23850 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23851 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23852 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23853 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23854 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23855 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23856 DATA (DL(K),K= 426, 510) /
23857 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23858 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23859 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23860 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23861 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23862 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23863 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23864 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23865 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23866 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23867 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23868 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23869 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23870 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23871 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23872 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23873 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23874 DATA (DL(K),K= 511, 595) /
23875 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23876 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23877 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23878 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23879 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23880 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23881 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23882 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23883 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23884 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23885 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23886 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23887 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23888 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23889 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23890 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23891 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23892 DATA (DL(K),K= 596, 680) /
23893 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23894 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23895 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23896 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23897 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23898 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23899 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23900 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23901 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23902 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23903 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23904 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23905 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23906 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23907 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23908 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23909 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23910 DATA (DL(K),K= 681, 765) /
23911 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23912 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23913 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23914 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23915 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23916 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23917 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23918 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23919 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23920 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23921 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23922 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23923 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23924 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23925 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23926 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23927 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23928 DATA (DL(K),K= 766, 850) /
23929 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23930 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23931 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23932 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23933 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23934 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23935 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23936 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23937 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23938 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23939 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23940 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23941 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23942 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23943 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23944 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23945 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23946 DATA (DL(K),K= 851, 935) /
23947 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23948 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23949 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23950 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23951 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23952 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23953 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23954 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23955 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23956 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23957 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23958 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23959 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23960 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23961 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23962 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23963 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23964 DATA (DL(K),K= 936, 1020) /
23965 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23966 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23967 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23968 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23969 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23970 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23971 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23972 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23973 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23974 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23975 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23976 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23977 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23978 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23979 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23980 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23981 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23982 DATA (DL(K),K= 1021, 1105) /
23983 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23984 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23985 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23986 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23987 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23988 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23989 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23990 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23991 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23992 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23993 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23994 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23995 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23996 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23997 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23998 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23999 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
24000 DATA (DL(K),K= 1106, 1190) /
24001 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
24002 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24003 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24004 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
24005 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
24006 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
24007 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
24008 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
24009 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
24010 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
24011 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
24012 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
24013 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
24014 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
24015 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
24016 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
24017 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
24018 DATA (DL(K),K= 1191, 1275) /
24019 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
24020 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
24021 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
24022 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
24023 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
24024 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
24025 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
24026 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24027 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24028 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24029 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24030 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24031 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24032 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24033 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24034 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24035 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24036 DATA (DL(K),K= 1276, 1360) /
24037 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24038 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24039 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24040 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24041 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24042 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24043 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24044 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24045 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24046 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24047 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24048 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24049 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24050 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24051 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24052 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24053 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24054 DATA (DL(K),K= 1361, 1445) /
24055 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24056 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24057 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24058 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24059 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24060 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24061 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24062 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24063 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24064 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24065 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24066 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24067 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24068 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24069 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24070 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24071 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24072 DATA (DL(K),K= 1446, 1530) /
24073 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24074 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24075 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24076 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24077 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24078 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24079 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24080 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24081 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24082 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24083 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24084 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24085 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24086 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24087 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24088 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24089 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24090 DATA (DL(K),K= 1531, 1615) /
24091 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24092 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24093 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24094 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24095 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24096 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24097 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24098 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24099 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24100 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24101 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24102 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24103 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24104 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24105 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24106 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24107 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24108 DATA (DL(K),K= 1616, 1700) /
24109 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24110 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24111 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24112 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24113 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24114 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24115 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24116 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24117 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24118 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24119 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24120 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24121 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24122 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24123 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24124 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24125 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24126 DATA (DL(K),K= 1701, 1785) /
24127 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24128 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24129 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24130 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24131 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24132 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24133 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24134 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24135 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24136 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24137 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24138 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24139 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24140 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24141 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24142 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24143 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24144 DATA (DL(K),K= 1786, 1870) /
24145 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24146 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24147 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24148 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24149 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24150 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24151 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24152 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24153 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24154 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24155 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24156 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24157 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24158 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24159 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24160 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24161 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24162 DATA (DL(K),K= 1871, 1955) /
24163 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24164 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24165 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24166 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24167 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24168 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24169 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24170 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24171 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24172 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24173 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24174 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24175 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24176 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24177 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24178 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24179 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24180 DATA (DL(K),K= 1956, 2040) /
24181 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24182 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24183 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24184 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24185 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24186 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24187 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24188 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24189 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24190 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24191 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24192 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24193 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24194 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24195 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24196 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24197 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24198 DATA (DL(K),K= 2041, 2125) /
24199 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24200 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24201 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24202 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24203 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24204 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24205 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24206 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24207 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24208 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24209 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24210 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24211 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24212 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24213 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24214 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24215 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24216 DATA (DL(K),K= 2126, 2210) /
24217 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24218 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24219 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24220 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24221 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24222 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24223 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24224 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24225 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24226 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24227 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24228 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24229 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24230 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24231 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24232 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24233 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24234 DATA (DL(K),K= 2211, 2295) /
24235 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24236 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24237 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24238 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24239 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24240 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24241 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24242 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24243 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24244 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24245 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24246 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24247 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24248 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24249 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24250 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24251 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24252 DATA (DL(K),K= 2296, 2380) /
24253 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24254 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24255 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24256 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24257 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24258 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24259 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24260 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24261 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24262 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24263 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24264 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24265 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24266 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24267 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24268 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24269 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24270 DATA (DL(K),K= 2381, 2465) /
24271 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24272 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24273 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24274 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24275 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24276 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24277 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24278 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24279 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24280 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24281 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24282 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24283 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24284 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24285 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24286 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24287 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24288 DATA (DL(K),K= 2466, 2550) /
24289 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24290 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24291 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24292 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24293 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24294 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24295 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24296 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24297 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24298 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24299 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24300 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24301 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24302 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24303 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24304 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24305 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24306 DATA (DL(K),K= 2551, 2635) /
24307 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24308 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24309 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24310 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24311 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24312 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24313 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24314 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24315 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24316 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24317 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24318 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24319 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24320 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24321 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24322 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24323 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24324 DATA (DL(K),K= 2636, 2720) /
24325 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24326 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24327 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24328 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24329 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24330 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24331 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24332 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24333 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24334 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24335 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24336 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24337 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24338 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24339 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24340 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24341 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24342 DATA (DL(K),K= 2721, 2805) /
24343 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24344 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24345 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24346 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24347 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24348 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24349 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24350 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24351 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24352 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24353 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24354 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24355 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24356 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24357 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24358 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24359 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24360 DATA (DL(K),K= 2806, 2890) /
24361 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24362 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24363 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24364 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24365 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24366 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24367 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24368 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24369 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24370 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24371 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24372 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24373 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24374 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24375 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24376 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24377 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24378 DATA (DL(K),K= 2891, 2975) /
24379 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24380 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24381 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24382 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24383 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24384 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24385 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24386 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24387 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24388 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24389 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24390 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24391 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24392 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24393 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24394 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24395 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24396 DATA (DL(K),K= 2976, 3060) /
24397 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24398 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24399 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24400 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24401 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24402 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24403 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24404 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24405 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24406 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24407 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24408 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24409 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24410 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24411 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24412 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24413 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24414 DATA (DL(K),K= 3061, 3145) /
24415 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24416 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24417 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24418 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24419 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24420 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24421 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24422 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24423 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24424 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24425 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24426 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24427 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24428 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24429 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24430 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24431 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24432 DATA (DL(K),K= 3146, 3230) /
24433 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24434 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24435 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24436 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24437 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24438 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24439 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24440 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24441 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24442 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24443 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24444 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24445 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24446 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24447 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24448 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24449 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24450 DATA (DL(K),K= 3231, 3315) /
24451 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24452 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24453 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24454 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24455 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24456 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24457 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24458 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24459 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24460 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24461 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24462 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24463 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24464 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24465 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24466 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24467 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24468 DATA (DL(K),K= 3316, 3400) /
24469 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24470 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24471 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24472 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24473 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24474 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24475 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24476 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24477 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24478 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24479 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24480 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24481 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24482 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24483 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24484 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24485 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24486 DATA (DL(K),K= 3401, 3485) /
24487 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24488 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24489 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24490 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24491 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24492 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24493 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24494 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24495 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24496 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24497 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24498 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24499 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24500 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24501 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24502 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24503 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24504 DATA (DL(K),K= 3486, 3570) /
24505 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24506 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24507 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24508 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24509 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24510 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24511 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24512 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24513 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24514 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24515 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24516 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24517 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24518 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24519 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24520 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24521 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24522 DATA (DL(K),K= 3571, 3655) /
24523 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24524 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24525 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24526 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24527 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24528 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24529 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24530 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24531 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24532 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24533 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24534 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24535 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24536 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24537 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24538 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24539 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24540 DATA (DL(K),K= 3656, 3740) /
24541 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24542 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24543 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24544 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24545 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24546 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24547 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24548 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24549 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24550 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24551 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24552 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24553 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24554 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24555 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24556 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24557 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24558 DATA (DL(K),K= 3741, 3825) /
24559 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24560 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24561 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24562 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24563 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24564 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24565 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24566 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24567 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24568 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24569 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24570 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24571 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24572 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24573 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24574 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24575 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24576 DATA (DL(K),K= 3826, 3910) /
24577 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24578 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24579 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24580 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24581 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24582 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24583 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24584 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24585 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24586 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24587 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24588 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24589 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24590 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24591 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24592 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24593 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24594 DATA (DL(K),K= 3911, 3995) /
24595 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24596 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24597 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24598 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24599 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24600 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24601 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24602 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24603 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24604 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24605 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24606 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24607 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24608 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24609 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24610 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24611 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24612 DATA (DL(K),K= 3996, 4000) /
24613 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24616 IF (X.GT.0.9985) RETURN
24617 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24623 F1(L) = GF(I,IS,KL)
24624 F2(L) = GF(I,IS1,KL)
24626 A1 = DT_CKMTFF(X,F1)
24627 A2 = DT_CKMTFF(X,F2)
24632 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24638 *$ CREATE DT_CKMTFF.FOR
24640 FUNCTION DT_CKMTFF(X,FVL)
24641 C**********************************************************************
24643 C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24644 C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24645 C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24648 C**********************************************************************
24651 DIMENSION FVL(25),XGRID(25)
24652 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24653 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24657 IF(X.LT.XGRID(I)) GO TO 2
24662 ELSE IF(I.GT.23) THEN
24668 BXI=LOG(1.-XGRID(I))
24670 BXJ=LOG(1.-XGRID(J))
24672 BXK=LOG(1.-XGRID(K))
24673 FI=LOG(ABS(FVL(I)) +1.E-15)
24674 FJ=LOG(ABS(FVL(J)) +1.E-16)
24675 FK=LOG(ABS(FVL(K)) +1.E-17)
24676 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24677 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24679 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24680 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24681 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24683 C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24684 C WRITE(6,2001) X,FVL
24685 C 2001 FORMAT(8E12.4)
24686 C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24688 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24692 *$ CREATE DT_FLUINI.FOR
24695 *===fluini=============================================================*
24697 SUBROUTINE DT_FLUINI
24699 ************************************************************************
24700 * Initialisation of the nucleon-nucleon cross section fluctuation *
24701 * treatment. The original version by J. Ranft. *
24702 * This version dated 21.04.95 is revised by S. Roesler. *
24703 ************************************************************************
24705 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24707 PARAMETER ( LINP = 10 ,
24710 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24712 PARAMETER ( A = 0.1D0,
24718 * n-n cross section fluctuations
24719 PARAMETER (NBINS = 1000)
24720 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24721 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24724 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24733 FLUS = ((X-B)/(OM*B))**N
24734 IF (FLUS.LE.20.0D0) THEN
24735 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24739 FLUSU = FLUSU+FLUSI(I)
24742 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24747 C1001 FORMAT(1X,'FLUCTUATIONS')
24748 C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24751 AF = DBLE(I)*0.001D0
24753 IF (AF.LE.FLUSI(J)) THEN
24754 FLUIXX(I) = FLUIX(J)
24760 FLUIXX(1) = FLUIX(1)
24761 FLUIXX(NBINS) = FLUIX(NBINS)
24766 *$ CREATE DT_SIGTBL.FOR
24769 *===sigtab=============================================================*
24771 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24773 ************************************************************************
24774 * This version dated 18.11.95 is written by S. Roesler *
24775 ************************************************************************
24777 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24779 PARAMETER ( LINP = 10 ,
24783 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24784 & OHALF=0.5D0,ONE=1.0D0)
24785 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24789 * particle properties (BAMJET index convention)
24791 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24792 & IICH(210),IIBAR(210),K1(210),K2(210)
24794 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24795 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24796 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24798 DATA LINIT /.FALSE./
24800 * precalculation and tabulation of elastic cross sections
24801 IF (ABS(MODE).EQ.1) THEN
24803 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24804 PLABLX = LOG10(PLO)
24805 PLABHX = LOG10(PHI)
24806 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24808 PLAB = PLABLX+DBLE(I-1)*DPLAB
24813 C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24814 C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24816 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24817 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24820 IF (MODE.EQ.1) THEN
24821 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24822 & (SIGEN(IDX,I),IDX=1,5)
24823 1000 FORMAT(F5.1,10F7.2)
24826 IF (MODE.EQ.1) CLOSE(LDAT)
24830 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24831 & .AND.(PTOT.LE.PHI) ) THEN
24833 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24834 PLABX = LOG10(PTOT)
24835 IF (PLABX.LE.PLABLX) THEN
24838 ELSEIF (PLABX.GE.PLABHX) THEN
24842 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24845 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24846 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24847 PBIN = PLAB2X-PLAB1X
24848 IF (PBIN.GT.TINY10) THEN
24849 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24854 SIG1 = SIGEP(IDX,I1)
24855 SIG2 = SIGEP(IDX,I2)
24857 SIG1 = SIGEN(IDX,I1)
24858 SIG2 = SIGEN(IDX,I2)
24860 SIGE = SIG1+RATX*(SIG2-SIG1)
24868 *$ CREATE DT_XSTABL.FOR
24871 *===xstabl=============================================================*
24873 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24875 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24877 PARAMETER ( LINP = 10 ,
24880 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24881 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24882 LOGICAL LLAB,LELOG,LQLOG
24884 * particle properties (BAMJET index convention)
24886 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24887 & IICH(210),IIBAR(210),K1(210),K2(210)
24888 * properties of interacting particles
24889 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24890 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24891 * Glauber formalism: cross sections
24892 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24893 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24894 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24895 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24896 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24897 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24898 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24899 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24900 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24901 & BSLOPE,NEBINI,NQBINI
24902 * emulsion treatment
24903 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24908 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24911 IF (ELO.GT.EHI) ELO = EHI
24912 LELOG = WHAT(3).LT.ZERO
24913 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24914 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24918 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24922 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24923 LQLOG = WHAT(6).LT.ZERO
24924 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24925 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24927 AQ2LO = LOG10(Q2LO)
24928 AQ2HI = LOG10(Q2HI)
24929 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24932 IF ( ELO.EQ. EHI) NEBINS = 0
24933 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24935 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24936 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24937 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24938 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24939 & ' A_p = ',I3,' A_t = ',I3,/)
24941 C IF (IJPROJ.NE.7) THEN
24942 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24943 * normalize fractions of emulsion components
24944 IF (NCOMPO.GT.0) THEN
24947 SUMFRA = SUMFRA+EMUFRA(I)
24949 IF (SUMFRA.GT.ZERO) THEN
24951 EMUFRA(I) = EMUFRA(I)/SUMFRA
24956 C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24960 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24962 E = ELO+DBLE(I-1)*DEBINS
24966 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24968 Q2 = Q2LO+DBLE(J-1)*DQBINS
24970 c IF (IJPROJ.NE.7) THEN
24974 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24980 IF (IJPROJ.EQ.7) Q2I = Q2
24981 IF (NCOMPO.GT.0) THEN
24984 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24987 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24988 C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24990 IF (NCOMPO.GT.0) THEN
25009 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
25010 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
25011 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
25012 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
25013 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
25014 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
25015 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
25016 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
25017 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
25018 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
25019 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
25020 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
25021 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
25022 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
25023 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
25024 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
25025 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
25026 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
25028 XPRO1= XPRO1+EMUFRA(IC)*YPRO
25038 WRITE(LOUT,'(8E9.3)')
25039 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25040 C WRITE(LOUT,'(4E9.3)')
25041 C & E,XDEL,XDQE,XDEL+XDQE
25043 WRITE(LOUT,'(11E10.3)')
25045 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25046 & XSQE2(1,1,1),XSPRO(1,1,1),
25047 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25048 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25049 & XSDEL(1,1,1)+XSDQE(1,1,1)
25050 C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25051 C & XSDEL(1,1,1)+XSDQE(1,1,1)
25055 c IF (IT.GT.1) THEN
25056 c IF (IXSQEL.EQ.0) THEN
25057 cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
25058 cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
25059 c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25060 c & STOT,ETOT,SIN,EIN,STOT0)
25061 c IF (IRATIO.EQ.1) THEN
25062 c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25063 cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25064 cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25065 c*!! save cross sections
25070 c STOT = STOT/(DBLE(IT)*STGP)
25071 c SIN = SIN/(DBLE(IT)*SIGP)
25078 c & ' XSTABL: qel. xs. not implemented for nuclei'
25085 c IF (IXSQEL.EQ.0) THEN
25086 c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25089 c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25093 c IF (IT.GT.1) THEN
25094 c IF (IXSQEL.EQ.0) THEN
25095 c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25096 c & STOT,ETOT,SIN,EIN,STOT0)
25097 c IF (IRATIO.EQ.1) THEN
25098 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25099 c*!! save cross sections
25104 c STOT = STOT/(DBLE(IT)*STGP)
25105 c SIN = SIN/(DBLE(IT)*SIGP)
25112 c & ' XSTABL: qel. xs. not implemented for nuclei'
25119 c IF (IXSQEL.EQ.0) THEN
25120 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25123 c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25127 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25128 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25129 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25130 c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25138 *$ CREATE DT_TESTXS.FOR
25141 *===testxs=============================================================*
25143 SUBROUTINE DT_TESTXS
25145 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25148 DIMENSION XSTOT(26,2),XSELA(26,2)
25150 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25151 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25152 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25153 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25158 APLABL = LOG10(PLABL)
25159 APLABH = LOG10(PLABH)
25160 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25162 ADP = APLABL+DBLE(I-1)*ADPLAB
25165 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25166 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25168 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25169 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25170 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25171 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25173 1000 FORMAT(F8.3,26F9.3)
25178 ************************************************************************
25180 * DTUNUC 2.0: library routines *
25181 * processed by S. Roesler, 6.5.95 *
25183 ************************************************************************
25185 * 1) Handling of parton momenta
25186 * SUBROUTINE MASHEL
25187 * SUBROUTINE DFERMI
25189 * 2) Handling of parton flavors and particle indices
25190 * INTEGER FUNCTION IPDG2B
25191 * INTEGER FUNCTION IB2PDG
25192 * INTEGER FUNCTION IQUARK
25193 * INTEGER FUNCTION IBJQUA
25194 * INTEGER FUNCTION ICIHAD
25195 * INTEGER FUNCTION IPDGHA
25196 * INTEGER FUNCTION MCHAD
25197 * SUBROUTINE FLAHAD
25199 * 3) Energy-momentum and quantum number conservation check routines
25202 * SUBROUTINE EVTEMC
25203 * SUBROUTINE EVTFLC
25204 * SUBROUTINE EVTCHG
25206 * 4) Transformations
25208 * SUBROUTINE LTRANS
25210 * SUBROUTINE DALTRA
25211 * SUBROUTINE DTRAFO
25212 * SUBROUTINE STTRAN
25213 * SUBROUTINE MYTRAN
25214 * SUBROUTINE LT2LAO
25215 * SUBROUTINE LT2LAB
25217 * 5) Sampling from distributions
25218 * INTEGER FUNCTION NPOISS
25219 * DOUBLE PRECISION FUNCTION SAMPXB
25220 * DOUBLE PRECISION FUNCTION SAMPEX
25221 * DOUBLE PRECISION FUNCTION SAMSQX
25222 * DOUBLE PRECISION FUNCTION BETREJ
25223 * DOUBLE PRECISION FUNCTION DGAMRN
25224 * DOUBLE PRECISION FUNCTION DBETAR
25225 * SUBROUTINE RANNOR
25227 * SUBROUTINE DSFECF
25230 * 6) Special functions, algorithms and service routines
25231 * DOUBLE PRECISION FUNCTION YLAMB
25234 * SUBROUTINE DT_XTIME
25236 * 7) Random number generator package
25237 * DOUBLE PRECISION FUNCTION DT_RNDM
25238 * SUBROUTINE DT_RNDMST
25239 * SUBROUTINE DT_RNDMIN
25240 * SUBROUTINE DT_RNDMOU
25241 * SUBROUTINE DT_RNDMTE
25243 ************************************************************************
25245 * 1) Handling of parton momenta *
25247 ************************************************************************
25248 *$ CREATE DT_MASHEL.FOR
25251 *===mashel=============================================================*
25253 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25255 ************************************************************************
25257 * rescaling of momenta of two partons to put both *
25260 * input: PA1,PA2 input momentum vectors *
25261 * XM1,2 desired masses of particles afterwards *
25262 * P1,P2 changed momentum vectors *
25264 * The original version is written by R. Engel. *
25265 * This version dated 12.12.94 is modified by S. Roesler. *
25266 ************************************************************************
25268 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25270 PARAMETER ( LINP = 10 ,
25273 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25275 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25279 * Lorentz transformation into system CMS
25284 XPTOT = SQRT(PX**2+PY**2+PZ**2)
25285 XMS = (EE-XPTOT)*(EE+XPTOT)
25286 IF(XMS.LT.(XM1+XM2)**2) THEN
25287 C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25295 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25296 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25299 C SID = SQRT((ONE-COD)*(ONE+COD))
25300 PPT = SQRT(P1(1)**2+P1(2)**2)
25304 IF(PTOT1*SID.GT.TINY10) THEN
25305 COF = P1(1)/(SID*PTOT1)
25306 SIF = P1(2)/(SID*PTOT1)
25307 ANORF = SQRT(COF*COF+SIF*SIF)
25311 * new CM momentum and energies (for masses XM1,XM2)
25312 XM12 = SIGN(XM1**2,XM1)
25313 XM22 = SIGN(XM2**2,XM2)
25315 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25316 EE1 = SQRT(XM12+PCMP**2)
25320 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25321 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25322 & PTOT1,P1(1),P1(2),P1(3),P1(4))
25323 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25324 & PTOT2,P2(1),P2(2),P2(3),P2(4))
25325 * check consistency
25327 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25329 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25331 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25333 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25338 IF (IDEV.NE.0) THEN
25339 WRITE(LOUT,'(/1X,A,I3)')
25340 & 'MASHEL: inconsistent transformation',IDEV
25341 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25342 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25343 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25344 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25345 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25346 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25355 *$ CREATE DT_DFERMI.FOR
25358 *===dfermi=============================================================*
25360 SUBROUTINE DT_DFERMI(GPART)
25362 ************************************************************************
25363 * Find largest of three random numbers. *
25364 ************************************************************************
25366 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25372 G(I)=DT_RNDM(GPART)
25374 IF (G(3).LT.G(2)) GOTO 40
25375 IF (G(3).LT.G(1)) GOTO 30
25380 40 IF (G(2).LT.G(1)) GOTO 30
25386 ************************************************************************
25388 * 2) Handling of parton flavors and particle indices *
25390 ************************************************************************
25391 *$ CREATE IDT_IPDG2B.FOR
25394 *===ipdg2b=============================================================*
25396 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25398 ************************************************************************
25400 * conversion of quark numbering scheme *
25402 * input: PDG parton numbering *
25403 * for diquarks: NN number of the constituent quark *
25404 * (e.g. ID=2301,NN=1 -> ICONV2=1) *
25406 * output: BAMJET particle codes *
25407 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25408 * 2 d 8 a-d -2 a-d *
25409 * 3 s 9 a-s -3 a-s *
25410 * 4 c 10 a-c -4 a-c *
25412 * This is a modified version of ICONV2 written by R. Engel. *
25413 * This version dated 13.12.94 is written by S. Roesler. *
25414 ************************************************************************
25416 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25418 PARAMETER ( LINP = 10 ,
25426 IF (IDA.GE.1000) KF = 4
25427 IDA = IDA/(10**(KF-NN))
25430 * exchange up and dn quarks
25433 ELSEIF (IDA.EQ.2) THEN
25438 IF (MODE.EQ.1) THEN
25449 *$ CREATE IDT_IB2PDG.FOR
25452 *===ib2pdg=============================================================*
25454 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25456 ************************************************************************
25458 * conversion of quark numbering scheme *
25460 * input: BAMJET particle codes *
25461 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25462 * 2 d 8 a-d -2 a-d *
25463 * 3 s 9 a-s -3 a-s *
25464 * 4 c 10 a-c -4 a-c *
25466 * output: PDG parton numbering *
25468 * This version dated 13.12.94 is written by S. Roesler. *
25469 ************************************************************************
25471 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25473 PARAMETER ( LINP = 10 ,
25477 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25478 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25479 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25480 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25481 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25485 IF (MODE.EQ.1) THEN
25486 IF (ID1.GT.6) IDA = -(ID1-6)
25487 IF (ID2.GT.6) IDB = -(ID2-6)
25490 IDT_IB2PDG = IHKKQ(IDA)
25492 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25498 *$ CREATE IDT_IQUARK.FOR
25501 *===ipdgqu=============================================================*
25503 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25505 ************************************************************************
25507 * quark contents according to PDG conventions *
25508 * (random selection in case of quark mixing) *
25510 * input: IDBAMJ BAMJET particle code *
25511 * K 1..3 quark number *
25513 * output: 1 d (anti --> neg.) *
25518 * This version written by R. Engel. *
25519 ************************************************************************
25521 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25524 IQ = IDT_IBJQUA(K,IDBAMJ)
25529 * exchange of up and down
25530 IF (ABS(IQ).EQ.1) THEN
25532 ELSEIF (ABS(IQ).EQ.2) THEN
25540 *$ CREATE IDT_IBJQUA.FOR
25543 *===ibamq==============================================================*
25545 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25547 ************************************************************************
25549 * quark contents according to BAMJET conventions *
25550 * (random selection in case of quark mixing) *
25552 * input: IDBAMJ BAMJET particle code *
25553 * K 1..3 quark number *
25555 * output: 1 u 7 u bar *
25560 * This version written by R. Engel. *
25561 ************************************************************************
25563 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25566 DIMENSION ITAB(3,210)
25567 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25568 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25569 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25570 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25572 C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25573 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25575 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25577 C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25578 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25580 C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25581 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25583 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25584 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25585 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25586 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25587 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25588 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25589 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
25590 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25591 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25592 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25593 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25594 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
25595 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25596 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25597 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25598 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25599 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25600 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25601 & 8, 8, 8, 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 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25605 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25606 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25607 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25608 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25609 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25610 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25611 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25612 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25613 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25614 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25615 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25616 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25617 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25618 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25619 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25620 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25621 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25622 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25623 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25624 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25625 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25626 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25627 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25628 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25629 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25630 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25631 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25632 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25633 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25634 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25635 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25636 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25637 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25638 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25639 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25640 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25641 DATA ((ITAB(I,K),I=1,3),K=181,210) /
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, 0, 0, 0,
25645 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25646 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25647 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25648 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25649 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25650 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25651 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25655 IF (ITAB(1,IDBAMJ).LE.200) THEN
25656 ID = ITAB(K,IDBAMJ)
25658 IF(IDOLD.NE.IDBAMJ) THEN
25659 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25660 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25672 *$ CREATE IDT_ICIHAD.FOR
25675 *===icihad=============================================================*
25677 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25679 ************************************************************************
25680 * Conversion of particle index PDG proposal --> BAMJET-index scheme *
25681 * This is a completely new version dated 25.10.95. *
25682 * Renamed to be not in conflict with the modified PHOJET-version *
25683 ************************************************************************
25685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25688 * hadron index conversion (BAMJET <--> PDG)
25689 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25690 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25695 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25696 IF (MCIND.LT.0) THEN
25701 IF (KPDG.GE.10000) THEN
25703 IDT_ICIHAD = IBAM5(JSIGN,I)
25704 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25707 ELSEIF (KPDG.GE.1000) THEN
25709 IDT_ICIHAD = IBAM4(JSIGN,I)
25710 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25713 ELSEIF (KPDG.GE.100) THEN
25715 IDT_ICIHAD = IBAM3(JSIGN,I)
25716 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25719 ELSEIF (KPDG.GE.10) THEN
25721 IDT_ICIHAD = IBAM2(JSIGN,I)
25722 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25731 *$ CREATE IDT_IPDGHA.FOR
25734 *===ipdgha=============================================================*
25736 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25738 ************************************************************************
25739 * Conversion of particle index BAMJET-index scheme --> PDG proposal *
25740 * Adopted from the original by S. Roesler. This version dated 12.5.95 *
25741 * Renamed to be not in conflict with the modified PHOJET-version *
25742 ************************************************************************
25744 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25747 * hadron index conversion (BAMJET <--> PDG)
25748 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25749 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25752 IDT_IPDGHA = IAMCIN(MCIND)
25757 *$ CREATE DT_FLAHAD.FOR
25760 *===flahad=============================================================*
25762 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25764 ************************************************************************
25765 * sampling of FLAvor composition for HADrons/photons *
25766 * ID BAMJET-id of hadron *
25767 * IF1,2,3 flavor content *
25768 * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25769 * Note: - u,d numbering as in BAMJET *
25770 * - ID .le. 30 !! *
25771 * This version dated 12.03.96 is written by S. Roesler *
25772 ************************************************************************
25774 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25777 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25778 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25779 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25780 & IQTCHR(-6:6),MQUARK(3,39)
25782 DIMENSION JSEL(3,6)
25783 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25787 * photon (charge dependent flavour sampling)
25788 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25792 ELSE IF(K.EQ.5) THEN
25799 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25807 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25808 IF1 = MQUARK(JSEL(1,IX),ID)
25809 IF2 = MQUARK(JSEL(2,IX),ID)
25810 IF3 = MQUARK(JSEL(3,IX),ID)
25811 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25814 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25823 *$ CREATE IDT_MCHAD.FOR
25826 *===mchad==============================================================*
25828 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25830 ************************************************************************
25831 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25832 * Adopted from the original by S. Roesler. This version dated 6.5.95 *
25834 * Last change 28.12.2006 by S. Roesler. *
25835 ************************************************************************
25837 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25840 DIMENSION ITRANS(210)
25841 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25842 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25843 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25844 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25845 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25846 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25847 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25849 IF ( ITDTU .GT. 0 ) THEN
25850 IDT_MCHAD = ITRANS(ITDTU)
25858 ************************************************************************
25860 * 3) Energy-momentum and quantum number conservation check routines *
25862 ************************************************************************
25863 *$ CREATE DT_EMC1.FOR
25866 *===emc1===============================================================*
25868 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25870 ************************************************************************
25871 * This version dated 15.12.94 is written by S. Roesler *
25872 ************************************************************************
25874 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25876 PARAMETER ( LINP = 10 ,
25879 PARAMETER (TINY10=1.0D-10)
25881 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25885 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25886 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25888 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25889 IF (MODE.EQ.1) THEN
25890 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25891 ELSEIF (MODE.EQ.2) THEN
25892 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25894 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25895 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25896 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25897 ELSEIF (MODE.LT.0) THEN
25898 IF (MODE.EQ.-1) THEN
25899 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25900 ELSEIF (MODE.EQ.-2) THEN
25901 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25903 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25904 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25905 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25908 IF (ABS(MODE).EQ.3) THEN
25909 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25910 IF (IREJ1.NE.0) GOTO 9999
25919 *$ CREATE DT_EMC2.FOR
25922 *===emc2===============================================================*
25924 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25927 ************************************************************************
25928 * MODE = 1 energy-momentum cons. check *
25929 * = 2 flavor-cons. check *
25930 * = 3 energy-momentum & flavor cons. check *
25931 * = 4 energy-momentum & charge cons. check *
25932 * = 5 energy-momentum & flavor & charge cons. check *
25933 * This version dated 16.01.95 is written by S. Roesler *
25934 ************************************************************************
25936 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25938 PARAMETER ( LINP = 10 ,
25941 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25944 PARAMETER (NMXHKK=200000)
25945 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25946 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25947 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25948 * extended event history
25949 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25950 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25958 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25959 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25960 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25961 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25962 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25964 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25965 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25966 & (ISTHKK(I).EQ.IP5)) THEN
25967 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25969 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25971 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25972 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25973 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25974 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25976 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25977 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25978 & (ISTHKK(I).EQ.IN5)) THEN
25979 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25981 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25983 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25984 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25985 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25986 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25989 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25990 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25991 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25992 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25993 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25994 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
26003 *$ CREATE DT_EVTEMC.FOR
26006 *===evtemc=============================================================*
26008 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
26010 ************************************************************************
26011 * This version dated 13.12.94 is written by S. Roesler *
26012 ************************************************************************
26014 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26016 PARAMETER ( LINP = 10 ,
26019 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
26023 PARAMETER (NMXHKK=200000)
26024 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26025 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26026 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26027 * flags for input different options
26028 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26029 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26030 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26036 IF (MODE.EQ.4) THEN
26039 ELSEIF (MODE.EQ.5) THEN
26042 ELSEIF (MODE.EQ.-1) THEN
26047 IF (ABS(MODE).EQ.3) THEN
26052 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26053 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26054 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26055 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26056 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26057 & ' event ',NEVHKK,
26058 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26072 IF (MODE.EQ.1) THEN
26091 *$ CREATE DT_EVTFLC.FOR
26094 *===evtflc=============================================================*
26096 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26098 ************************************************************************
26099 * Flavor conservation check. *
26100 * ID identity of particle *
26101 * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
26102 * = 2 ID for particle/resonance in BAMJET numbering scheme *
26103 * = 3 ID for particle/resonance in PDG numbering scheme *
26104 * MODE = 1 initialization and add ID *
26105 * =-1 initialization and subtract ID *
26107 * =-2 subtract ID *
26108 * = 3 check flavor cons. *
26109 * IPOS flag to give position of call of EVTFLC to output *
26110 * unit in case of violation *
26111 * This version dated 10.01.95 is written by S. Roesler *
26112 ************************************************************************
26114 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26116 PARAMETER ( LINP = 10 ,
26119 PARAMETER (TINY10=1.0D-10)
26123 IF (MODE.EQ.3) THEN
26125 WRITE(LOUT,'(1X,A,I3,A,I3)')
26126 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26135 IF (MODE.EQ.1) IFL = 0
26136 IF (ID.EQ.0) RETURN
26141 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26142 IF (IDD.GE.1000) NQ = 3
26144 IFBAM = IDT_IPDG2B(ID,I,2)
26145 IF (ABS(IFBAM).EQ.1) THEN
26146 IFBAM = SIGN(2,IFBAM)
26147 ELSEIF (ABS(IFBAM).EQ.2) THEN
26148 IFBAM = SIGN(1,IFBAM)
26150 IF (MODE.GT.0) THEN
26160 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26161 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26163 IF (MODE.GT.0) THEN
26164 IFL = IFL+IDT_IQUARK(I,IDD)
26166 IFL = IFL-IDT_IQUARK(I,IDD)
26177 *$ CREATE DT_EVTCHG.FOR
26180 *===evtchg=============================================================*
26182 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26184 ************************************************************************
26185 * Charge conservation check. *
26186 * ID identity of particle (PDG-numbering scheme) *
26187 * MODE = 1 initialization *
26188 * =-2 subtract ID-charge *
26189 * = 2 add ID-charge *
26190 * = 3 check charge cons. *
26191 * IPOS flag to give position of call of EVTCHG to output *
26192 * unit in case of violation *
26193 * This version dated 10.01.95 is written by S. Roesler *
26194 * Last change: s.r. 21.01.01 *
26195 ************************************************************************
26197 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26199 PARAMETER ( LINP = 10 ,
26204 PARAMETER (NMXHKK=200000)
26205 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26206 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26207 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26208 * particle properties (BAMJET index convention)
26210 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26211 & IICH(210),IIBAR(210),K1(210),K2(210)
26215 IF (MODE.EQ.1) THEN
26221 IF (MODE.EQ.3) THEN
26222 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26223 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26224 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26225 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26235 IF (ID.EQ.0) RETURN
26237 IDD = IDT_ICIHAD(ID)
26238 * modification 21.1.01: use intrinsic phojet-functions to determine charge
26239 * and baryon number
26240 C IF (IDD.GT.0) THEN
26241 C IF (MODE.EQ.2) THEN
26242 C ICH = ICH+IICH(IDD)
26243 C IBAR = IBAR+IIBAR(IDD)
26244 C ELSEIF (MODE.EQ.-2) THEN
26245 C ICH = ICH-IICH(IDD)
26246 C IBAR = IBAR-IIBAR(IDD)
26249 C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26250 C CALL DT_EVTOUT(4)
26253 IF (MODE.EQ.2) THEN
26254 ICH = ICH+IPHO_CHR3(ID,1)/3
26255 IBAR = IBAR+IPHO_BAR3(ID,1)/3
26256 ELSEIF (MODE.EQ.-2) THEN
26257 ICH = ICH-IPHO_CHR3(ID,1)/3
26258 IBAR = IBAR-IPHO_BAR3(ID,1)/3
26268 ************************************************************************
26270 * 4) Transformations *
26272 ************************************************************************
26273 *$ CREATE DT_LTINI.FOR
26276 *===ltini==============================================================*
26278 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26280 ************************************************************************
26281 * Initializations of Lorentz-transformations, calculation of Lorentz- *
26283 * This version dated 13.11.95 is written by S. Roesler. *
26284 ************************************************************************
26286 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26288 PARAMETER ( LINP = 10 ,
26291 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26292 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26294 * Lorentz-parameters of the current interaction
26295 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26296 & UMO,PPCM,EPROJ,PPROJ
26297 * properties of photon/lepton projectiles
26298 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26299 * particle properties (BAMJET index convention)
26301 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26302 & IICH(210),IIBAR(210),K1(210),K2(210)
26303 * nucleon-nucleon event-generator
26306 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26310 IF (MCGENE.NE.3) THEN
26311 * lepton-projectiles and PHOJET: initialize real photon instead
26312 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26313 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26314 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26323 AMP = AAM(IDP)-SQRT(ABS(Q2))
26325 AMP2 = SIGN(AMP**2,AMP)
26327 IF (ECM0.GT.ZERO) THEN
26328 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26329 IF (AMP2.GT.ZERO) THEN
26330 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26332 PPN = SQRT(EPN**2-AMP2)
26335 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26336 IF (IDP.EQ.7) EPN = ABS(EPN)
26337 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26338 IF (AMP2.GT.ZERO) THEN
26339 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26341 PPN = SQRT(EPN**2-AMP2)
26343 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26344 IF (AMP2.GT.ZERO) THEN
26345 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26347 EPN = SQRT(PPN**2+AMP2)
26350 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26355 IF (AMP2.GT.ZERO) THEN
26356 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26357 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26362 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26368 IF (ECM0.GT.ZERO) THEN
26371 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26372 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26373 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26374 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26377 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26378 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26379 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26380 IF (MODE.EQ.1) THEN
26383 PNUCL(3) = -PGAMM(3)
26384 PNUCL(4) = SQRT(S)-PGAMM(4)
26387 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26388 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26391 * neglect lepton masses
26392 C AMLPT2 = AAM(IDPR)**2
26395 IF (ECM0.GT.ZERO) THEN
26398 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26399 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26400 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26401 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26404 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26405 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26406 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26409 PNUCL(3) = -PLEPT0(3)
26410 PNUCL(4) = SQRT(S)-PLEPT0(4)
26412 * Lorentz-parameter for transformation Lab. - projectile rest system
26413 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26422 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26427 GACMS(1) = (ETARG+AMP)/UMO
26428 BGCMS(1) = PTARG/UMO
26430 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26431 GACMS(2) = (EPROJ+AMT)/UMO
26432 BGCMS(2) = PPROJ/UMO
26433 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26442 *$ CREATE DT_LTRANS.FOR
26445 *===ltrans=============================================================*
26447 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26449 ************************************************************************
26450 * Lorentz-transformations. *
26451 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
26452 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26453 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26454 * This version dated 01.11.95 is written by S. Roesler. *
26455 ************************************************************************
26457 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26459 PARAMETER ( LINP = 10 ,
26462 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26464 PARAMETER (SQTINF=1.0D+15)
26466 * particle properties (BAMJET index convention)
26468 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26469 & IICH(210),IIBAR(210),K1(210),K2(210)
26473 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26475 * check particle mass for consistency (numerical rounding errors)
26476 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26477 AMO2 = (PEO-PO)*(PEO+PO)
26478 AMORQ2 = AAM(ID)**2
26479 AMDIF2 = ABS(AMO2-AMORQ2)
26480 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26481 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26487 C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26493 *$ CREATE DT_LTNUC.FOR
26496 *===ltnuc==============================================================*
26498 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26500 ************************************************************************
26501 * Lorentz-transformations. *
26502 * PIN longitudnal momentum (input) *
26503 * EIN energy (input) *
26504 * POUT transformed long. momentum (output) *
26505 * EOUT transformed energy (output) *
26506 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
26507 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26508 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26509 * This version dated 01.11.95 is written by S. Roesler. *
26510 ************************************************************************
26512 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26514 PARAMETER ( LINP = 10 ,
26517 PARAMETER (ZERO=0.0D0)
26519 * Lorentz-parameters of the current interaction
26520 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26521 & UMO,PPCM,EPROJ,PPROJ
26527 IF (ABS(MODE).EQ.1) THEN
26528 BG = -SIGN(BGLAB,DBLE(MODE))
26529 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26530 & DUM1,DUM2,DUM3,POUT,EOUT)
26531 ELSEIF (ABS(MODE).EQ.2) THEN
26532 BG = SIGN(BGCMS(1),DBLE(MODE))
26533 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26534 & DUM1,DUM2,DUM3,POUT,EOUT)
26535 ELSEIF (ABS(MODE).EQ.3) THEN
26536 BG = -SIGN(BGCMS(2),DBLE(MODE))
26537 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26538 & DUM1,DUM2,DUM3,POUT,EOUT)
26540 WRITE(LOUT,1000) MODE
26541 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26549 *$ CREATE DT_DALTRA.FOR
26552 *===daltra=============================================================*
26554 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26556 ************************************************************************
26557 * Arbitrary Lorentz-transformation. *
26558 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26559 ************************************************************************
26561 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26563 PARAMETER (ONE=1.0D0)
26565 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26566 PE = EP/(GA+ONE)+EC
26570 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26576 *$ CREATE DT_DTRAFO.FOR
26579 *====dtrafo============================================================*
26581 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26582 & PL,CXL,CYL,CZL,EL)
26584 C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26586 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26589 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26590 SID = SQRT(1.D0-COD*COD)
26594 PLZ = GAM*PCMZ+BGAM*ECM
26595 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26596 EL = GAM*ECM+BGAM*PCMZ
26597 C ROTATION INTO THE ORIGINAL DIRECTION
26599 SIZ = SQRT(1.D0-COZ**2)
26600 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26605 *$ CREATE DT_STTRAN.FOR
26608 *====sttran============================================================*
26610 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26612 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26614 DATA ANGLSQ/1.D-30/
26615 ************************************************************************
26616 * VERSION BY J. RANFT *
26619 * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26621 * INPUT VARIABLES: *
26622 * XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26623 * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26624 * ANGLE OF "SCATTERING" *
26625 * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26626 * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26627 * OF "SCATTERING" *
26629 * OUTPUT VARIABLES: *
26630 * X,Y,Z = NEW DIRECTION COSINES *
26632 * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26633 ************************************************************************
26636 * Changed by A. Ferrari
26638 * IF (ABS(XO)-0.0001D0) 1,1,2
26639 * 1 IF (ABS(YO)-0.0001D0) 3,3,2
26642 IF ( A .LT. ANGLSQ ) THEN
26651 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26652 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26659 *$ CREATE DT_MYTRAN.FOR
26662 *===mytran=============================================================*
26664 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26666 ************************************************************************
26667 * This subroutine rotates the coordinate frame *
26668 * a) theta around y *
26669 * b) phi around z if IMODE = 1 *
26671 * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26672 * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26673 * z' 0 0 1 -sin(th) 0 cos(th) z *
26675 * and vice versa if IMODE = 0. *
26676 * This version dated 5.4.94 is based on the original version DTRAN *
26677 * by J. Ranft and is written by S. Roesler. *
26678 ************************************************************************
26680 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26682 PARAMETER ( LINP = 10 ,
26686 IF (IMODE.EQ.1) THEN
26687 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26688 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26689 Z=-SDE *XO +CDE *ZO
26691 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26693 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26698 *$ CREATE DT_LT2LAO.FOR
26701 *===lt2lab=============================================================*
26703 SUBROUTINE DT_LT2LAO
26705 ************************************************************************
26706 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26707 * for final state particles/fragments defined in nucleon-nucleon-cms *
26708 * and transforms them back to the lab. *
26709 * This version dated 16.11.95 is written by S. Roesler *
26710 ************************************************************************
26712 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26714 PARAMETER ( LINP = 10 ,
26719 PARAMETER (NMXHKK=200000)
26720 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26721 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26722 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26723 * extended event history
26724 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26725 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26730 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26731 DO 1 I=NPOINT(4),NEND
26733 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26734 & (ISTHKK(I).EQ.1001)) THEN
26735 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26737 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26738 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26739 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26740 ISTHKK(I) = 3*ISTHKK(I)
26743 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26744 ISTHKK(I) = SIGN(3,ISTHKK(I))
26753 *$ CREATE DT_LT2LAB.FOR
26756 *===lt2lab=============================================================*
26758 SUBROUTINE DT_LT2LAB
26760 ************************************************************************
26761 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26762 * for final state particles/fragments defined in nucleon-nucleon-cms *
26763 * and transforms them to the lab. *
26764 * This version dated 07.01.96 is written by S. Roesler *
26765 ************************************************************************
26767 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26769 PARAMETER ( LINP = 10 ,
26774 PARAMETER (NMXHKK=200000)
26775 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26776 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26777 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26778 * extended event history
26779 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26780 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26783 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26784 DO 1 I=NPOINT(4),NHKK
26785 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26786 & (ISTHKK(I).EQ.1001)) THEN
26788 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26797 ************************************************************************
26799 * 5) Sampling from distributions *
26801 ************************************************************************
26802 *$ CREATE IDT_NPOISS.FOR
26805 *===npoiss=============================================================*
26807 INTEGER FUNCTION IDT_NPOISS(AVN)
26809 ************************************************************************
26810 * Sample according to Poisson distribution with Poisson parameter AVN. *
26811 * The original version written by J. Ranft. *
26812 * This version dated 11.1.95 is written by S. Roesler. *
26813 ************************************************************************
26815 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26817 PARAMETER ( LINP = 10 ,
26827 IF (A.GE.EXPAVN) THEN
26836 *$ CREATE DT_SAMPXB.FOR
26839 *===sampxb=============================================================*
26841 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26843 ************************************************************************
26844 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26845 * Processed by S. Roesler, 6.5.95 *
26846 ************************************************************************
26848 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26850 PARAMETER (TWO=2.0D0)
26852 A1 = LOG(X1+SQRT(X1**2+B**2))
26853 A2 = LOG(X2+SQRT(X2**2+B**2))
26855 A = AN*DT_RNDM(A1)+A1
26857 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26862 *$ CREATE DT_SAMPEX.FOR
26865 *===sampex=============================================================*
26867 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26869 ************************************************************************
26870 * Sampling from f(x)=1./x between x1 and x2. *
26871 * Processed by S. Roesler, 6.5.95 *
26872 ************************************************************************
26874 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26876 PARAMETER (ONE=1.0D0)
26881 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26886 *$ CREATE DT_SAMSQX.FOR
26889 *===samsqx=============================================================*
26891 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26893 ************************************************************************
26894 * Sampling from f(x)=1./x^0.5 between x1 and x2. *
26895 * Processed by S. Roesler, 6.5.95 *
26896 ************************************************************************
26898 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26900 PARAMETER (ONE=1.0D0)
26903 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26908 *$ CREATE DT_SAMPLW.FOR
26911 *===samplw=============================================================*
26913 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26915 ************************************************************************
26916 * Sampling from f(x)=1/x^b between x_min and x_max. *
26917 * S. Roesler, 18.4.98 *
26918 ************************************************************************
26920 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26922 PARAMETER (ONE=1.0D0)
26926 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26929 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26935 *$ CREATE DT_BETREJ.FOR
26938 *===betrej=============================================================*
26940 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26942 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26945 PARAMETER ( LINP = 10 ,
26948 PARAMETER (ONE=1.0D0)
26950 IF (XMIN.GE.XMAX)THEN
26951 WRITE (LOUT,500) XMIN,XMAX
26952 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26957 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26958 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26959 YY = BETMAX*DT_RNDM(XX)
26960 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26961 IF (YY.GT.BETXX) GOTO 10
26967 *$ CREATE DT_DGAMRN.FOR
26970 *===dgamrn=============================================================*
26972 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26974 ************************************************************************
26975 * Sampling from Gamma-distribution. *
26976 * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26977 * Processed by S. Roesler, 6.5.95 *
26978 ************************************************************************
26980 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26982 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26987 IF (F.EQ.ZERO) GOTO 20
26990 IF (NCOU.GE.11) GOTO 20
26991 IF (R.LT.F/(F+2.71828D0)) GOTO 30
26992 YYY = LOG(DT_RNDM(R)+TINY9)/F
26993 IF (ABS(YYY).GT.50.0D0) GOTO 20
26995 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26999 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
27000 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
27001 40 IF (N.EQ.0) GOTO 70
27004 60 Z = Z*DT_RNDM(Z)
27006 70 DT_DGAMRN = Y/ALAM
27011 *$ CREATE DT_DBETAR.FOR
27014 *===dbetar=============================================================*
27016 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
27018 ************************************************************************
27019 * Sampling from Beta -distribution between 0.0 and 1.0 *
27020 * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
27021 * Processed by S. Roesler, 6.5.95 *
27022 ************************************************************************
27024 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27027 Y = DT_DGAMRN(1.0D0,GAM)
27028 Z = DT_DGAMRN(1.0D0,ETA)
27029 DT_DBETAR = Y/(Y+Z)
27034 *$ CREATE DT_RANNOR.FOR
27037 *===rannor=============================================================*
27039 SUBROUTINE DT_RANNOR(X,Y)
27041 ************************************************************************
27042 * Sampling from Gaussian distribution. *
27043 * Processed by S. Roesler, 6.5.95 *
27044 ************************************************************************
27046 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27048 PARAMETER (TINY10=1.0D-10)
27050 CALL DT_DSFECF(SFE,CFE)
27051 V = MAX(TINY10,DT_RNDM(X))
27052 A = SQRT(-2.D0*LOG(V))
27059 *$ CREATE DT_DPOLI.FOR
27062 *===dpoli==============================================================*
27064 SUBROUTINE DT_DPOLI(CS,SI)
27066 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27071 IF (U.LT.0.5D0) CS=-CS
27072 SI = SQRT(1.0D0-CS*CS+1.0D-10)
27077 *$ CREATE DT_DSFECF.FOR
27080 *===dsfecf=============================================================*
27082 SUBROUTINE DT_DSFECF(SFE,CFE)
27084 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27086 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27094 IF (XY.GT.ONE) GOTO 1
27097 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27101 *$ CREATE DT_RACO.FOR
27104 *===raco===============================================================*
27106 SUBROUTINE DT_RACO(WX,WY,WZ)
27108 ************************************************************************
27109 * Direction cosines of random uniform (isotropic) direction in three *
27110 * dimensional space *
27111 * Processed by S. Roesler, 20.11.95 *
27112 ************************************************************************
27114 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27116 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27119 X = TWO*DT_RNDM(WX)-ONE
27123 IF (X2+Y2.GT.ONE) GOTO 10
27125 CFE = (X2-Y2)/(X2+Y2)
27126 SFE = TWO*X*Y/(X2+Y2)
27127 * z = 1/2 [ 1 + cos (theta) ]
27130 WZ = SQRT(Z*(ONE-Z))
27138 ************************************************************************
27140 * 6) Special functions, algorithms and service routines *
27142 ************************************************************************
27143 *$ CREATE DT_YLAMB.FOR
27146 *===ylamb==============================================================*
27148 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27150 ************************************************************************
27152 * auxiliary function for three particle decay mode *
27153 * (standard LAMBDA**(1/2) function) *
27155 * Adopted from an original version written by R. Engel. *
27156 * This version dated 12.12.94 is written by S. Roesler. *
27157 ************************************************************************
27159 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27163 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27164 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27165 DT_YLAMB = SQRT(XLAM)
27170 *$ CREATE DT_SORT.FOR
27173 *===sort1==============================================================*
27175 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27177 ************************************************************************
27178 * This subroutine sorts entries in A in increasing/decreasing order *
27180 * MODE = 1 increasing in A(3,i=1..N) *
27181 * = 2 decreasing in A(3,i=1..N) *
27182 * This version dated 21.04.95 is revised by S. Roesler *
27183 ************************************************************************
27185 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27197 IF (MODE.EQ.1) THEN
27198 IF (A(3,I).LE.A(3,J)) GOTO 20
27200 IF (A(3,I).GE.A(3,J)) GOTO 20
27213 IF (L.EQ.1) GOTO 10
27218 *$ CREATE DT_SORT1.FOR
27221 *===sort1==============================================================*
27223 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27225 ************************************************************************
27226 * This subroutine sorts entries in A in increasing/decreasing order *
27228 * MODE = 1 increasing in A(i=1..N) *
27229 * = 2 decreasing in A(i=1..N) *
27230 * This version dated 21.04.95 is revised by S. Roesler *
27231 ************************************************************************
27233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27236 DIMENSION A(N),IDX(N)
27245 IF (MODE.EQ.1) THEN
27246 IF (A(I).LE.A(J)) GOTO 20
27248 IF (A(I).GE.A(J)) GOTO 20
27258 IF (L.EQ.1) GOTO 10
27263 *$ CREATE DT_XTIME.FOR
27266 *===xtime==============================================================*
27268 SUBROUTINE DT_XTIME
27270 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27272 PARAMETER ( LINP = 10 ,
27276 CHARACTER DAT*9,TIM*11
27280 C CALL GETDAT(IYEAR,IMONTH,IDAY)
27281 C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27285 C WRITE(LOUT,1000) DAT,TIM
27286 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27291 ************************************************************************
27293 * 7) Random number generator package *
27295 * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
27296 * SERVICE ROUTINES. *
27297 * THE ALGORITHM IS FROM *
27298 * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27299 * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27300 * IMPLEMENTATION BY K. HAHN DEC. 88, *
27301 * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27302 * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27303 * THE PERIOD IS ABOUT 2**144, *
27304 * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27305 * THE PACKAGE CONTAINS *
27306 * FUNCTION DT_RNDM(I) : GENERATOR *
27307 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27308 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27309 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27310 * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27312 * FUNCTION DT_RNDM(I) *
27313 * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27314 * I - DUMMY VARIABLE, NOT USED *
27315 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27316 * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27317 * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27318 * NA? MUST BE IN 1..178 AND NOT ALL 1 *
27319 * 12,34,56 ARE THE STANDARD VALUES *
27320 * NB1 MUST BE IN 1..168 *
27321 * 78 IS THE STANDARD VALUE *
27322 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27323 * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27324 * AS AFTER THE LAST DT_RNDMOU CALL ) *
27325 * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27326 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27327 * TAKES SEED FROM GENERATOR *
27328 * U(97),C,CD,CM,I,J - SEED VALUES *
27329 * SUBROUTINE DT_RNDMTE(IO) *
27330 * TEST OF THE GENERATOR *
27331 * IO - DEFINES OUTPUT *
27332 * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27333 * = 1 OUTPUT INDEPENDEND ON AN ERROR *
27334 * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27336 * AS BEFORE CALL OF DT_RNDMTE *
27337 ************************************************************************
27338 *$ CREATE DT_RNDM.FOR
27341 c$$$*===rndm===============================================================*
27343 c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27345 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27348 c$$$* random number generator
27349 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27351 c$$$* counter of calls to random number generator
27352 c$$$* uncomment if needed
27353 c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27354 c$$$C LOGICAL LFIRST
27355 c$$$C DATA LFIRST /.TRUE./
27357 c$$$* counter of calls to random number generator
27358 c$$$* uncomment if needed
27359 c$$$C IF (LFIRST) THEN
27362 c$$$C LFIRST = .FALSE.
27365 c$$$ DT_RNDM = U(I)-U(J)
27366 c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27367 c$$$ U(I) = DT_RNDM
27369 c$$$ IF ( I.EQ.0 ) I = 97
27371 c$$$ IF ( J.EQ.0 ) J = 97
27373 c$$$ IF ( C.LT.0.0D0 ) C = C+CM
27374 c$$$ DT_RNDM = DT_RNDM-C
27375 c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27377 c$$$ IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27379 c$$$* counter of calls to random number generator
27380 c$$$* uncomment if needed
27381 c$$$C IRNCT0 = IRNCT0+1
27386 c$$$*$ CREATE DT_RNDMST.FOR
27387 c$$$*COPY DT_RNDMST
27389 c$$$*===rndmst=============================================================*
27391 c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27393 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27396 c$$$* random number generator
27397 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27405 c$$$ DO 20 II2 = 1,97
27408 c$$$ DO 10 II1 = 1,24
27409 c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27413 c$$$ MB1 = MOD(53*MB1+1,169)
27414 c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27415 c$$$ 10 T = 0.5D0*T
27417 c$$$ C = 362436.0D0/16777216.0D0
27418 c$$$ CD = 7654321.0D0/16777216.0D0
27419 c$$$ CM = 16777213.0D0/16777216.0D0
27423 c$$$*$ CREATE DT_RNDMIN.FOR
27424 c$$$*COPY DT_RNDMIN
27426 c$$$*===rndmin=============================================================*
27428 c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27430 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27433 c$$$* random number generator
27434 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27436 c$$$ DIMENSION UIN(97)
27438 c$$$ DO 10 KKK = 1,97
27439 c$$$ 10 U(KKK) = UIN(KKK)
27449 c$$$*$ CREATE DT_RNDMOU.FOR
27450 c$$$*COPY DT_RNDMOU
27452 c$$$*===rndmou=============================================================*
27454 c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27456 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27459 c$$$* random number generator
27460 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27462 c$$$ DIMENSION UOUT(97)
27464 c$$$ DO 10 KKK = 1,97
27465 c$$$ 10 UOUT(KKK) = U(KKK)
27475 c$$$*$ CREATE DT_RNDMTE.FOR
27476 c$$$*COPY DT_RNDMTE
27478 c$$$*===rndmte=============================================================*
27480 c$$$ SUBROUTINE DT_RNDMTE(IO)
27482 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27485 c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27486 c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27487 c$$$ +8354498.D0, 10633180.D0/
27489 c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27490 c$$$ CALL DT_RNDMST(12,34,56,78)
27491 c$$$ DO 10 II1 = 1,20000
27492 c$$$ 10 XX = DT_RNDM(XX)
27494 c$$$ DO 20 II2 = 1,6
27495 c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27496 c$$$ D(II2) = X(II2)-U(II2)
27497 c$$$ 20 SD = SD+D(II2)
27498 c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27500 c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27501 c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27502 c$$$C WRITE(6,1000)
27503 c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27508 c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27509 c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27510 c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27511 c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27514 *$ CREATE PHO_RNDM.FOR
27517 *===pho_rndm===========================================================*
27519 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27521 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27524 PHO_RNDM = DT_RNDM(DUMMY)
27532 *===pyr================================================================*
27534 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27536 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27539 DUMMY = DBLE(IDUMMY)
27540 PYR = DT_RNDM(DUMMY)
27545 *$ CREATE DT_TITLE.FOR
27548 *===title==============================================================*
27550 SUBROUTINE DT_TITLE
27552 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27554 PARAMETER ( LINP = 10 ,
27559 CHARACTER*11 CCHANG
27560 DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27563 WRITE(LOUT,1000) CVERSI,CCHANG
27564 1000 FORMAT(1X,'+-------------------------------------------------',
27565 & '----------------------+',/,
27566 & 1X,'|',71X,'|',/,
27567 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27568 & 1X,'|',71X,'|',/,
27569 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27570 & 1X,'|',71X,'|',/,
27571 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27572 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27573 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27574 & 1X,'|',71X,'|',/,
27575 & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27577 & 1X,'|',71X,'|',/,
27578 & 1X,'+-------------------------------------------------',
27579 & '----------------------+',/,
27580 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27581 & 'Stefan.Roesler@cern.ch |',/,
27582 & 1X,'+-------------------------------------------------',
27583 & '----------------------+',/)
27588 *$ CREATE DT_EVTINI.FOR
27591 *===evtini=============================================================*
27593 SUBROUTINE DT_EVTINI
27595 ************************************************************************
27596 * Initialization of DTEVT1. *
27597 * This version dated 15.01.94 is written by S. Roesler *
27598 ************************************************************************
27600 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27602 PARAMETER ( LINP = 10 ,
27607 PARAMETER (NMXHKK=200000)
27608 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27609 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27610 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27611 * extended event history
27612 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27613 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27616 COMMON /DTEVNO/ NEVENT,ICASCA
27617 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27618 * emulsion treatment
27619 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27622 * initialization of DTEVT1/DTEVT2
27624 IF (NEVENT.EQ.1) NEND = NMXHKK
27652 C* initialization of DTLTRA
27653 C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27658 *$ CREATE DT_STATIS.FOR
27661 *===statis=============================================================*
27663 SUBROUTINE DT_STATIS(MODE)
27665 ************************************************************************
27666 * Initialization and output of run-statistics. *
27667 * MODE = 1 initialization *
27669 * This version dated 23.01.94 is written by S. Roesler *
27670 ************************************************************************
27672 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27674 PARAMETER ( LINP = 10 ,
27677 PARAMETER (TINY3=1.0D-3)
27680 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27681 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27683 * rejection counter
27684 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27685 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27686 & IREXCI(3),IRDIFF(2),IRINC
27687 * central particle production, impact parameter biasing
27688 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27689 * various options for treatment of partons (DTUNUC 1.x)
27690 * (chain recombination, Cronin,..)
27691 LOGICAL LCO2CR,LINTPT
27692 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27694 * nucleon-nucleon event-generator
27697 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27698 * flags for particle decays
27699 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27700 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27701 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27702 * diquark-breaking mechanism
27703 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27705 DIMENSION PP(4),PT(4)
27712 * initialize statistics counter
27725 * initialize rejection counter
27756 * statistics counter
27758 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27759 & 28X,'---------------------')
27760 IF (ICREQU.GT.0) THEN
27761 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27762 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27763 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27764 & 'event',11X,F9.1)
27766 IF (ICDIFF(1).NE.0) THEN
27767 WRITE(LOUT,1009) ICDIFF
27768 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27769 & 'low mass high mass',/,24X,'single diffraction',
27770 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27772 IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27773 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27774 & DBLE(ICSAMP)/DBLE(ICCPRO)
27775 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27776 & ' of sampled Glauber-events per event',9X,F9.1,/,
27777 & 2X,'fraction of production cross section',21X,F10.6)
27779 IF (ICSAMP.GT.0) THEN
27780 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27781 & DBLE(ICDTA)/DBLE(ICSAMP)
27782 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27783 & ' nucleons after x-sampling',2(4X,F6.2))
27786 IF (MCGENE.EQ.1) THEN
27787 IF (ICSAMP.GT.0) THEN
27788 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27789 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27790 & ' event',3X,F9.1)
27791 IF (ISICHA.EQ.1) THEN
27792 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27793 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27794 & 'of single chains per event',13X,F9.1)
27797 IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27799 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27800 & 23X,'mean number of chains mean number of chains',/,
27801 & 23X,'sampled hadronized having mass of a reso.')
27802 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27803 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27804 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27805 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27806 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27807 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27808 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27809 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27810 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27811 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27812 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27813 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27814 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27816 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27817 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27818 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27819 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27820 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27821 & DBLE(IRHHA)/DBLE(ICREQU),
27822 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27823 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27824 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27825 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27826 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27827 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27828 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27829 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27830 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27831 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27832 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27833 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27834 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27835 & F7.2,/,1X,'Total no. of rej.',
27836 & ' in chain-systems treatment (GETCSY)',/,43X,
27837 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27838 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27839 & 1X,'Total no. of rej. in DPM-treatment of one event',
27840 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27841 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27842 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27843 & 'IREXCI(3) = ',I5,/)
27845 ELSEIF (MCGENE.EQ.2) THEN
27846 WRITE(LOUT,1010) ELOJET
27847 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27850 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27851 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27852 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27853 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27854 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27855 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27856 & ((ICEVTG(I,J),I=1,8),J=3,7),
27857 & ((ICEVTG(I,J),I=1,8),J=19,21),
27858 & (ICEVTG(I,8),I=1,8),
27859 & ((ICEVTG(I,J),I=1,8),J=22,24),
27860 & (ICEVTG(I,9),I=1,8),
27861 & ((ICEVTG(I,J),I=1,8),J=25,28),
27862 & ((ICEVTG(I,J),I=1,8),J=10,18)
27863 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27864 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27865 & ' no-dif.',8I8,/,
27866 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27867 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27868 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27869 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27870 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27872 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27873 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27874 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27876 1013 FORMAT(/,1X,'2. chain system statistics -',
27877 & ' mean numbers per evt:',/,30X,'---------------------',
27878 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27879 IF (ICSAMP.GT.0) THEN
27881 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27882 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27883 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27884 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27885 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27886 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27887 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27888 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27889 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27890 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27891 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27892 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27893 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
27896 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27897 IF (ICSAMP.GT.0) THEN
27899 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27900 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27901 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27902 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27903 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27904 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27905 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27906 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27907 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27908 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27909 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27910 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27911 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
27917 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27918 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27919 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27920 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27921 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27922 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27923 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27924 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27925 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27926 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27927 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27928 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27929 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27930 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27931 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27932 & DBRKA(3,1),DBRKA(3,2),
27933 & DBRKA(3,3),DBRKA(3,4)
27934 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27935 & DBRKR(3,1),DBRKR(3,2),
27936 & DBRKR(3,3),DBRKR(3,4)
27937 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27938 & DBRKA(3,5),DBRKA(3,6),
27939 & DBRKA(3,7),DBRKA(3,8)
27940 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27941 & DBRKR(3,5),DBRKR(3,6),
27942 & DBRKR(3,7),DBRKR(3,8)
27946 IF (MCGENE.EQ.2) THEN
27947 C CALL PHO_PHIST(-2,SIGMAX)
27948 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27956 *$ CREATE DT_EVTOUT.FOR
27959 *===evtout=============================================================*
27961 SUBROUTINE DT_EVTOUT(MODE)
27963 ************************************************************************
27964 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27965 * 3 plot entries of extended DTEVT1 (DTEVT2) *
27966 * 4 plot entries of DTEVT1 and DTEVT2 *
27967 * This version dated 11.12.94 is written by S. Roesler *
27968 ************************************************************************
27970 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27972 PARAMETER ( LINP = 10 ,
27976 PARAMETER (NMXHKK=200000)
27977 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27978 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27979 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27981 DIMENSION IRANGE(NMXHKK)
27983 IF (MODE.EQ.2) RETURN
27985 CALL DT_EVTPLO(IRANGE,MODE)
27990 *$ CREATE DT_EVTPLO.FOR
27993 *===evtplo=============================================================*
27995 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27997 ************************************************************************
27998 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27999 * 2 plot entries of DTEVT1 given by IRANGE *
28000 * 3 plot entries of extended DTEVT1 (DTEVT2) *
28001 * 4 plot entries of DTEVT1 and DTEVT2 *
28002 * 5 plot rejection counter *
28003 * This version dated 11.12.94 is written by S. Roesler *
28004 ************************************************************************
28006 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28008 PARAMETER ( LINP = 10 ,
28015 PARAMETER (NMXHKK=200000)
28016 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28017 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28018 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28019 * extended event history
28020 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28021 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28023 * rejection counter
28024 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
28025 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
28026 & IREXCI(3),IRDIFF(2),IRINC
28028 DIMENSION IRANGE(NMXHKK)
28030 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
28032 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
28033 & 15X,' --------------------------',/,/,
28034 & ' ST ID M1 M2 D1 D2 PX PY',
28037 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28038 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28039 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28041 C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28042 C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28043 C & PHKK(3,I),PHKK(4,I)
28044 C WRITE(LOUT,'(4E15.4)')
28045 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28046 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28047 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
28051 C WRITE(LOUT,1006) I,ISTHKK(I),
28052 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28053 C & WHKK(2,I),WHKK(3,I)
28054 C1006 FORMAT(1X,I4,I6,6E10.3)
28058 IF (MODE.EQ.2) THEN
28063 IF (IRANGE(NC).EQ.-100) GOTO 9999
28065 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28066 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28067 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28072 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28074 1002 FORMAT(/,1X,'EVTPLO:',14X,
28075 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28076 & 15X,' -----------------------------------',/,/,
28077 & ' ST ID M1 M2 D1 D2 IDR IDXR',
28078 & ' NOBAM IDCH M',/)
28080 C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28083 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28084 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28085 CALL PYNAME(KF,CHAU)
28086 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28087 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28088 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28090 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28095 IF (MODE.EQ.5) THEN
28097 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
28098 & 15X,' --------------------------',/)
28099 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28101 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
28102 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
28103 & 1X,'IREMC = ',10I5,/,
28104 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
28110 *$ CREATE DT_EVTPUT.FOR
28113 *===evtput=============================================================*
28115 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28117 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28119 PARAMETER ( LINP = 10 ,
28122 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28123 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28126 PARAMETER (NMXHKK=200000)
28127 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28128 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28129 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28130 * extended event history
28131 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28132 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28134 * Lorentz-parameters of the current interaction
28135 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28136 & UMO,PPCM,EPROJ,PPROJ
28137 * particle properties (BAMJET index convention)
28139 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28140 & IICH(210),IIBAR(210),K1(210),K2(210)
28142 C IF (MODE.GT.100) THEN
28143 C WRITE(LOUT,'(1X,A,I5,A,I5)')
28144 C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28145 C NHKK = NHKK-MODE+100
28152 IF (NHKK.GT.NMXHKK) THEN
28153 WRITE(LOUT,1000) NHKK
28154 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28155 & '! program execution stopped..')
28158 IF (M1.LT.0) MO1 = NHKK+M1
28159 IF (M2.LT.0) MO2 = NHKK+M2
28162 JMOHKK(1,NHKK) = MO1
28163 JMOHKK(2,NHKK) = MO2
28167 IDXRES(NHKK) = IDXR
28169 ** here we need to do something..
28170 IF (ID.EQ.88888) THEN
28171 IDMO1 = ABS(IDHKK(MO1))
28172 IDMO2 = ABS(IDHKK(MO2))
28173 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28174 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28175 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28176 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28180 IDBAM(NHKK) = IDT_ICIHAD(ID)
28182 IF (JDAHKK(1,MO1).NE.0) THEN
28183 JDAHKK(2,MO1) = NHKK
28185 JDAHKK(1,MO1) = NHKK
28189 IF (JDAHKK(1,MO2).NE.0) THEN
28190 JDAHKK(2,MO2) = NHKK
28192 JDAHKK(1,MO2) = NHKK
28195 C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28196 C PTOT = SQRT(PX**2+PY**2+PZ**2)
28197 C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28198 C AMRQ = AAM(IDBAM(NHKK))
28199 C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28200 C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28201 C & (PTOT.GT.ZERO)) THEN
28202 C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28203 CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28205 C PTOT1 = PTOT-DELTA
28206 C PX = PX*PTOT1/PTOT
28207 C PY = PY*PTOT1/PTOT
28208 C PZ = PZ*PTOT1/PTOT
28215 PTOT = SQRT( PX**2+PY**2+PZ**2 )
28216 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28217 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28218 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28220 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28221 C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28222 C & WRITE(LOUT,'(1X,A,G10.3)')
28223 C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28224 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28227 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28228 * special treatment for chains:
28229 * z coordinate of chain in Lab = pos. of target nucleon
28230 * time of chain-creation in Lab = time of passage of projectile
28231 * nucleus at pos. of taget nucleus
28232 C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28233 C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28234 VHKK(1,NHKK) = VHKK(1,MO2)
28235 VHKK(2,NHKK) = VHKK(2,MO2)
28236 VHKK(3,NHKK) = VHKK(3,MO2)
28237 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28238 C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28239 C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28240 WHKK(1,NHKK) = WHKK(1,MO1)
28241 WHKK(2,NHKK) = WHKK(2,MO1)
28242 WHKK(3,NHKK) = WHKK(3,MO1)
28243 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28247 VHKK(I,NHKK) = VHKK(I,MO1)
28248 WHKK(I,NHKK) = WHKK(I,MO1)
28252 VHKK(I,NHKK) = ZERO
28253 WHKK(I,NHKK) = ZERO
28261 *$ CREATE DT_CHASTA.FOR
28264 *===chasta=============================================================*
28266 SUBROUTINE DT_CHASTA(MODE)
28268 ************************************************************************
28269 * This subroutine performs CHAin STAtistics and checks sequence of *
28270 * partons in dtevt1 and sorts them with projectile partons coming *
28271 * first if necessary. *
28273 * This version dated 8.5.00 is written by S. Roesler. *
28274 ************************************************************************
28276 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28278 PARAMETER ( LINP = 10 ,
28285 PARAMETER (NMXHKK=200000)
28286 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28287 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28288 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28289 * extended event history
28290 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28291 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28293 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28294 PARAMETER (MAXCHN=10000)
28295 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28297 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28298 & CCHTYP(9),ICHSTA(10),ITOT(10)
28299 DATA ICHCFG /1800*0/
28300 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28301 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28302 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28303 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28304 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28305 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28306 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28307 & 'ad aq',' d ad','ad d ',' g g '/
28311 IF (MODE.EQ.-1) THEN
28314 * loop over DTEVT1 and analyse chain configurations
28316 ELSEIF (MODE.EQ.0) THEN
28317 DO 21 IDX=NPOINT(3),NHKK
28318 IDCHK = IDHKK(IDX)/10000
28319 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28320 & (IDHKK(IDX).NE.80000).AND.
28321 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28322 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28323 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28328 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28329 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28331 IMO1 = IST1-10*IMO1
28333 IMO2 = IST2-10*IMO2
28334 * swop parton entries if necessary since we need projectile partons
28335 * to come first in the common
28336 IF (IMO1.GT.IMO2) THEN
28337 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28339 I0 = JMOHKK(1,IDX)-1+K
28340 I1 = JMOHKK(2,IDX)+1-K
28342 ISTHKK(I0) = ISTHKK(I1)
28345 IDHKK(I0) = IDHKK(I1)
28347 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28348 & JDAHKK(1,JMOHKK(1,I0)) = I1
28349 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28350 & JDAHKK(2,JMOHKK(1,I0)) = I1
28351 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28352 & JDAHKK(1,JMOHKK(2,I0)) = I1
28353 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28354 & JDAHKK(2,JMOHKK(2,I0)) = I1
28355 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28356 & JDAHKK(1,JMOHKK(1,I1)) = I0
28357 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28358 & JDAHKK(2,JMOHKK(1,I1)) = I0
28359 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28360 & JDAHKK(1,JMOHKK(2,I1)) = I0
28361 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28362 & JDAHKK(2,JMOHKK(2,I1)) = I0
28363 ITMP = JMOHKK(1,I0)
28364 JMOHKK(1,I0) = JMOHKK(1,I1)
28365 JMOHKK(1,I1) = ITMP
28366 ITMP = JMOHKK(2,I0)
28367 JMOHKK(2,I0) = JMOHKK(2,I1)
28368 JMOHKK(2,I1) = ITMP
28369 ITMP = JDAHKK(1,I0)
28370 JDAHKK(1,I0) = JDAHKK(1,I1)
28371 JDAHKK(1,I1) = ITMP
28372 ITMP = JDAHKK(2,I0)
28373 JDAHKK(2,I0) = JDAHKK(2,I1)
28374 JDAHKK(2,I1) = ITMP
28379 PHKK(J,I0) = PHKK(J,I1)
28380 VHKK(J,I0) = VHKK(J,I1)
28381 WHKK(J,I0) = WHKK(J,I1)
28387 PHKK(5,I0) = PHKK(5,I1)
28390 IDRES(I0) = IDRES(I1)
28393 IDXRES(I0) = IDXRES(I1)
28396 NOBAM(I0) = NOBAM(I1)
28399 IDBAM(I0) = IDBAM(I1)
28402 IDCH(I0) = IDCH(I1)
28405 IHIST(1,I0) = IHIST(1,I1)
28408 IHIST(2,I0) = IHIST(2,I1)
28412 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28413 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28415 * parton 1 (projectile side)
28416 IF (IST1.EQ.21) THEN
28418 ELSEIF (IST1.EQ.22) THEN
28420 ELSEIF (IST1.EQ.31) THEN
28422 ELSEIF (IST1.EQ.32) THEN
28424 ELSEIF (IST1.EQ.41) THEN
28426 ELSEIF (IST1.EQ.42) THEN
28428 ELSEIF (IST1.EQ.51) THEN
28430 ELSEIF (IST1.EQ.52) THEN
28432 ELSEIF (IST1.EQ.61) THEN
28434 ELSEIF (IST1.EQ.62) THEN
28438 c & ' CHASTA: unknown parton status flag (',
28439 c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28442 ID = IDHKK(JMOHKK(1,IDX))
28443 IF (ABS(ID).LE.4) THEN
28449 ELSEIF (ABS(ID).GE.1000) THEN
28455 ELSEIF (ID.EQ.21) THEN
28459 & ' CHASTA: inconsistent parton identity (',
28460 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28464 * parton 2 (target side)
28465 IF (IST2.EQ.21) THEN
28467 ELSEIF (IST2.EQ.22) THEN
28469 ELSEIF (IST2.EQ.31) THEN
28471 ELSEIF (IST2.EQ.32) THEN
28473 ELSEIF (IST2.EQ.41) THEN
28475 ELSEIF (IST2.EQ.42) THEN
28477 ELSEIF (IST2.EQ.51) THEN
28479 ELSEIF (IST2.EQ.52) THEN
28481 ELSEIF (IST2.EQ.61) THEN
28483 ELSEIF (IST2.EQ.62) THEN
28487 c & ' CHASTA: unknown parton status flag (',
28488 c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28491 ID = IDHKK(JMOHKK(2,IDX))
28492 IF (ABS(ID).LE.4) THEN
28498 ELSEIF (ABS(ID).GE.1000) THEN
28504 ELSEIF (ID.EQ.21) THEN
28508 & ' CHASTA: inconsistent parton identity (',
28509 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28514 ITYPE = ICHTYP(ITYP1,ITYP2)
28515 IF (ITYPE.NE.0) THEN
28516 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28517 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28518 ICHCFG(IDX1,IDX2,ITYPE,2) =
28519 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28522 IF (NCHAIN.GT.MAXCHN) THEN
28523 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28527 IDXCHN(1,NCHAIN) = IDX
28528 IDXCHN(2,NCHAIN) = ITYPE
28531 & ' CHASTA: inconsistent chain at entry ',IDX
28537 * write statistics to output unit
28539 ELSEIF (MODE.EQ.1) THEN
28540 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28542 WRITE(LOUT,'(/,2A)')
28543 & ' -----------------------------------------',
28544 & '------------------------------------'
28546 & ' p\\t 21 22 31 32 41',
28547 & ' 42 51 52 61 62'
28549 & ' -----------------------------------------',
28550 & '------------------------------------'
28554 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28557 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28561 ISUM = ISUM+ICHCFG(I,J,K,1)
28564 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28565 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28567 C WRITE(LOUT,'(2A)')
28568 C & ' -----------------------------------------',
28569 C & '-------------------------------'
28573 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28579 *$ CREATE PHO_PHIST.FOR
28582 *===pohist=============================================================*
28584 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28586 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28589 PARAMETER ( LINP = 10 ,
28592 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28593 * Glauber formalism: cross sections
28594 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28595 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28596 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28597 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28598 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28599 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28600 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28601 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28602 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28603 & BSLOPE,NEBINI,NQBINI
28606 IF (IMODE.EQ.10) THEN
28610 IF (ABS(IMODE).LT.1000) THEN
28611 * PHOJET-statistics
28612 C CALL POHISX(IMODE,WEIGHT)
28613 IF (IMODE.EQ.-1) THEN
28615 XSTOT(1,1,1) = WEIGHT
28617 IF (IMODE.EQ. 1) MODE = 2
28618 IF (IMODE.EQ.-2) MODE = 3
28619 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28620 C IF (MODE.EQ.3) WRITE(LOUT,*)
28621 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28622 CALL DT_HISTOG(MODE)
28623 CALL DT_USRHIS(MODE)
28625 * DTUNUC-statistics
28627 C IF (MODE.EQ.3) WRITE(LOUT,*)
28628 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28629 CALL DT_HISTOG(MODE)
28630 CALL DT_USRHIS(MODE)
28636 *$ CREATE DT_SWPPHO.FOR
28639 *===swppho=============================================================*
28641 SUBROUTINE DT_SWPPHO(ILAB)
28643 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28645 PARAMETER ( LINP = 10 ,
28648 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28653 PARAMETER (NMXHKK=200000)
28654 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28655 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28656 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28657 * extended event history
28658 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28659 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28661 * flags for input different options
28662 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28663 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28664 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28665 * properties of photon/lepton projectiles
28666 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28669 C PARAMETER (NMXHEP=2000)
28670 C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28671 C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28672 C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28673 C COMMON /PLASAV/ PLAB
28675 C standard particle data interface
28677 PARAMETER (NMXHEP=4000)
28678 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28679 DOUBLE PRECISION PHEP,VHEP
28680 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28681 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28682 & VHEP(4,NMXHEP),NSD1, NSD2, NDD
28683 C extension to standard particle data interface (PHOJET specific)
28684 INTEGER IMPART,IPHIST,ICOLOR
28685 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28686 C global event kinematics and particle IDs
28687 INTEGER IFPAP,IFPAB
28688 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28689 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28693 DATA LSTART /.TRUE./
28695 C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28696 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28700 IDP = IDT_ICIHAD(IFPAP(1))
28701 IDT = IDT_ICIHAD(IFPAP(2))
28703 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28712 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28714 IF (ISTHEP(I).EQ.1) THEN
28717 IDHKK(NHKK) = IDHEP(I)
28723 PHKK(K,NHKK) = PHEP(K,I)
28724 VHKK(K,NHKK) = ZERO
28725 WHKK(K,NHKK) = ZERO
28727 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28728 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28729 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28730 PHKK(5,NHKK) = PHEP(5,I)
28734 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28742 *$ CREATE DT_HISTOG.FOR
28745 *===histog=============================================================*
28747 SUBROUTINE DT_HISTOG(MODE)
28749 ************************************************************************
28750 * This version dated 25.03.96 is written by S. Roesler *
28751 ************************************************************************
28753 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28755 PARAMETER ( LINP = 10 ,
28762 PARAMETER (NMXHKK=200000)
28763 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28764 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28765 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28766 * extended event history
28767 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28768 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28770 * event flag used for histograms
28771 COMMON /DTNORM/ ICEVT,IEVHKK
28772 * flags for activated histograms
28773 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28778 *------------------------------------------------------------------
28782 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28783 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28786 *------------------------------------------------------------------
28787 * filling of histogram with event-record
28792 CALL DT_SWPFSP(I,LFSP,LRNL)
28794 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28795 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28797 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28799 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28802 *------------------------------------------------------------------
28805 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28806 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28811 *$ CREATE DT_SWPFSP.FOR
28814 *===swpfsp=============================================================*
28816 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28818 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28820 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28821 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28823 & BOG =TWOPI/360.0D0)
28826 PARAMETER (NMXHKK=200000)
28827 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28828 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28829 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28830 * extended event history
28831 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28832 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28834 * particle properties (BAMJET index convention)
28836 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28837 & IICH(210),IIBAR(210),K1(210),K2(210)
28838 * Lorentz-parameters of the current interaction
28839 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28840 & UMO,PPCM,EPROJ,PPROJ
28841 * flags for input different options
28842 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28843 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28844 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28845 * (original name: PAREVT)
28846 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28847 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28848 PARAMETER ( NALLWP = 39 )
28849 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28850 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28851 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28852 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28853 * temporary storage for one final state particle
28854 LOGICAL LFRAG,LGREY,LBLACK
28855 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28856 & SINTHE,COSTHE,THETA,THECMS,
28857 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28858 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28859 & LFRAG,LGREY,LBLACK
28867 IF (LEVPRT) ISTRNL = 1001
28869 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28873 IF (IDHKK(IDX).LT.80000) THEN
28875 IBARY = IIBAR(IDBJT)
28876 ICHAR = IICH(IDBJT)
28878 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28881 ICHAR = IDXRES(IDX)
28882 AMASS = PHKK(5,IDX)
28884 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28885 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28886 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28887 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28888 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28898 PTOT = SQRT(PT2+PZ**2)
28899 SINTHE = PT/MAX(PTOT,TINY14)
28900 COSTHE = PZ/MAX(PTOT,TINY14)
28901 IF (COSTHE.GT.ONE) THEN
28903 ELSEIF (COSTHE.LT.-ONE) THEN
28904 THETA = TWOPI/2.0D0
28906 THETA = ACOS(COSTHE)
28909 **sr 15.4.96 new E_t-definition
28910 IF (IBARY.GT.0) THEN
28912 ELSEIF (IBARY.LT.0) THEN
28913 ET = (EKIN+TWO*AMASS)*SINTHE
28918 XLAB = PZ/MAX(PPROJ,TINY14)
28919 C XLAB = PE/MAX(EPROJ,TINY14)
28920 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28921 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28924 IF (PMINUS.GT.TINY14) THEN
28925 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28929 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28930 ETA = -LOG(TAN(THETA/TWO))
28934 IF (IFRAME.EQ.1) THEN
28935 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28936 PPLUS = EECMS+PZCMS
28937 PMINUS = EECMS-PZCMS
28938 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28939 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28943 PTOTCM = SQRT(PT2+PZCMS**2)
28944 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28945 IF (COSTH.GT.ONE) THEN
28947 ELSEIF (COSTH.LT.-ONE) THEN
28948 THECMS = TWOPI/2.0D0
28950 THECMS = ACOS(COSTH)
28952 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28953 ETACMS = -LOG(TAN(THECMS/TWO))
28957 XF = PZCMS/MAX(PPCM,TINY14)
28958 THECMS = THECMS/BOG
28969 * set flag for "grey/black"
28973 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28974 IF (MULDEF.EQ.1) THEN
28976 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28977 & (EK.LE.375.0D-3) ).OR.
28978 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28979 & (EK.LE. 56.0D-3) ).OR.
28980 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28981 & (EK.LE. 56.0D-3) ).OR.
28982 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28983 & (EK.LE.198.0D-3) ).OR.
28984 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28985 & (EK.LE.198.0D-3) ).OR.
28986 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28987 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28988 & (IDBJT.NE.16).AND.
28989 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28991 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28992 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28993 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28994 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28995 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28996 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28997 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28998 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
29002 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
29003 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
29006 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
29012 ICHAR = IDXRES(IDX)
29013 AMASS = PHKK(5,IDX)
29020 PTOT = SQRT(PT2+PZ**2)
29021 SINTHE = PT/MAX(PTOT,TINY14)
29022 COSTHE = PZ/MAX(PTOT,TINY14)
29023 IF (COSTHE.GT.ONE) THEN
29025 ELSEIF (COSTHE.LT.-ONE) THEN
29026 THETA = TWOPI/2.0D0
29028 THETA = ACOS(COSTHE)
29031 **sr 15.4.96 new E_t-definition
29035 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
29036 ETA = -LOG(TAN(THETA/TWO))
29048 *$ CREATE DT_HIMULT.FOR
29051 *===himult=============================================================*
29053 SUBROUTINE DT_HIMULT(MODE)
29055 ************************************************************************
29056 * Tables of average energies/multiplicities. *
29057 * This version dated 30.08.2000 is written by S. Roesler *
29058 ************************************************************************
29060 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29062 PARAMETER ( LINP = 10 ,
29065 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29067 PARAMETER (SWMEXP=1.7D0)
29069 CHARACTER*8 ANAMEH(4)
29071 * particle properties (BAMJET index convention)
29073 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29074 & IICH(210),IIBAR(210),K1(210),K2(210)
29075 * temporary storage for one final state particle
29076 LOGICAL LFRAG,LGREY,LBLACK
29077 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29078 & SINTHE,COSTHE,THETA,THECMS,
29079 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29080 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29081 & LFRAG,LGREY,LBLACK
29082 * event flag used for histograms
29083 COMMON /DTNORM/ ICEVT,IEVHKK
29084 * Lorentz-parameters of the current interaction
29085 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29086 & UMO,PPCM,EPROJ,PPROJ
29088 PARAMETER (NOPART=210)
29089 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29090 & AVPT(4,NOPART),IAVPT(4,NOPART)
29091 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
29095 *------------------------------------------------------------------
29110 *------------------------------------------------------------------
29111 * filling of histogram with event-record
29113 IF (PE.LT.0.0D0) THEN
29114 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
29117 IF (.NOT.LFRAG) THEN
29119 IF (LGREY) IVEL = 3
29120 IF (LBLACK) IVEL = 4
29121 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
29122 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
29123 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
29124 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
29125 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
29126 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29127 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
29128 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29129 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
29130 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29131 IF (IDBJT.LT.116) THEN
29132 * total energy, multiplicity
29133 AVE(1,30) = AVE(1,30) +PE
29134 AVE(IVEL,30) = AVE(IVEL,30)+PE
29135 AVPT(1,30) = AVPT(1,30) +PT
29136 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
29137 IAVPT(1,30) = IAVPT(1,30) +1
29138 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29139 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
29140 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
29141 AVMULT(1,30) = AVMULT(1,30) +ONE
29142 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29143 * charged energy, multiplicity
29144 IF (ICHAR.LT.0) THEN
29145 AVE(1,26) = AVE(1,26) +PE
29146 AVE(IVEL,26) = AVE(IVEL,26)+PE
29147 AVPT(1,26) = AVPT(1,26) +PT
29148 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
29149 IAVPT(1,26) = IAVPT(1,26) +1
29150 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29151 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
29152 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
29153 AVMULT(1,26) = AVMULT(1,26) +ONE
29154 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29156 IF (ICHAR.NE.0) THEN
29157 AVE(1,27) = AVE(1,27) +PE
29158 AVE(IVEL,27) = AVE(IVEL,27)+PE
29159 AVPT(1,27) = AVPT(1,27) +PT
29160 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
29161 IAVPT(1,27) = IAVPT(1,27) +1
29162 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29163 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
29164 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
29165 AVMULT(1,27) = AVMULT(1,27) +ONE
29166 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29173 *------------------------------------------------------------------
29177 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29178 & 29X,'---------------------',/)
29179 IF (MULDEF.EQ.1) THEN
29180 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29184 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29185 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
29186 & ,F4.2,' black: beta < ',F4.2,/)
29188 WRITE(LOUT,3003) SWMEXP
29189 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
29190 & 13X,'| total fast',
29191 C & ' grey black K f(',F3.1,')',/,1X,
29192 & ' grey black <pt> f(',F3.1,')',/,1X,
29193 & '------------+--------------',
29194 & '-------------------------------------------------')
29197 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29198 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29199 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29200 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29203 WRITE(LOUT,3004) ANAME(I),I,
29204 & AVMULT(1,I),AVMULT(2,I),
29205 & AVMULT(3,I),AVMULT(4,I),
29206 C & AVE(1,I),AVSWM(1,I)
29207 & AVPT(1,I),AVSWM(1,I)
29208 ELSEIF (I.LE.119) THEN
29209 WRITE(LOUT,3004) ANAMEH(I-115),I,
29210 & AVMULT(1,I),AVMULT(2,I),
29211 & AVMULT(3,I),AVMULT(4,I),
29212 C & AVE(1,I),AVSWM(1,I)
29213 & AVPT(1,I),AVSWM(1,I)
29215 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29218 C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29219 C & AVMULT(3,27)+AVMULT(4,27)
29225 *$ CREATE DT_HISTAT.FOR
29228 *===histat=============================================================*
29230 SUBROUTINE DT_HISTAT(IDX,MODE)
29232 ************************************************************************
29233 * This version dated 26.02.96 is written by S. Roesler *
29235 * Last change 27.12.2006 by S. Roesler. *
29236 ************************************************************************
29238 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29240 PARAMETER ( LINP = 10 ,
29243 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29244 PARAMETER (NDIM=199)
29247 PARAMETER (NMXHKK=200000)
29248 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29249 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29250 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29251 * extended event history
29252 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29253 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29255 * particle properties (BAMJET index convention)
29257 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29258 & IICH(210),IIBAR(210),K1(210),K2(210)
29259 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29260 * Glauber formalism: cross sections
29261 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29262 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29263 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29264 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29265 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29266 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29267 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29268 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29269 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29270 & BSLOPE,NEBINI,NQBINI
29271 * emulsion treatment
29272 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29274 * properties of interacting particles
29275 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29276 * rejection counter
29277 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29278 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29279 & IREXCI(3),IRDIFF(2),IRINC
29280 * statistics: residual nuclei
29281 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29282 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29283 & NINCST(2,4),NINCEV(2),
29284 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29285 & NRESPB(2),NRESCH(2),NRESEV(4),
29286 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29288 * parameter for intranuclear cascade
29290 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29291 * (original name: PAREVT)
29292 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29293 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29294 PARAMETER ( NALLWP = 39 )
29295 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29296 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29297 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29298 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29299 * (original name: FRBKCM)
29300 PARAMETER ( MXFFBK = 6 )
29301 PARAMETER ( MXZFBK = 9 )
29302 PARAMETER ( MXNFBK = 10 )
29303 PARAMETER ( MXAFBK = 16 )
29304 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29305 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29306 PARAMETER ( NXAFBK = MXAFBK + 1 )
29307 PARAMETER ( MXPSST = 300 )
29308 PARAMETER ( MXPSFB = 41000 )
29309 LOGICAL LFRMBK, LNCMSS
29310 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29311 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29312 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29313 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29314 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29315 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29316 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29317 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29318 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
29319 * (original name: INPFLG)
29320 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29321 * temporary storage for one final state particle
29322 LOGICAL LFRAG,LGREY,LBLACK
29323 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29324 & SINTHE,COSTHE,THETA,THECMS,
29325 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29326 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29327 & LFRAG,LGREY,LBLACK
29328 * event flag used for histograms
29329 COMMON /DTNORM/ ICEVT,IEVHKK
29330 * statistics: double-Pomeron exchange
29331 COMMON /DTFLG2/ INTFLG,IPOPO
29333 DIMENSION EMUSAM(NCOMPX)
29335 CHARACTER*13 CMSG(3)
29336 DATA CMSG /'not requested','not requested','not requested'/
29338 GOTO (1,2,3,4,5) MODE
29340 *------------------------------------------------------------------
29343 * emulsion treatment
29344 IF (NCOMPO.GT.0) THEN
29349 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29370 IF (J.LE.2) NINCHR(I,J) = 0
29371 IF (J.LE.3) NINCCO(I,J) = 0
29372 IF (J.LE.4) NINCST(I,J) = 0
29381 **dble Po statistics.
29385 *------------------------------------------------------------------
29386 * filling of histogram with event-record
29388 IF (IST.EQ.-1) THEN
29389 IF (.NOT.LFRAG) THEN
29390 IF (IDPDG.EQ.2212) THEN
29391 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29392 ELSEIF (IDPDG.EQ.2112) THEN
29393 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29394 ELSEIF (IDPDG.EQ.22) THEN
29395 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29396 ELSEIF (IDPDG.EQ.80000) THEN
29397 IF (IDBJT.EQ.116) THEN
29398 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29399 ELSEIF (IDBJT.EQ.117) THEN
29400 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29401 ELSEIF (IDBJT.EQ.118) THEN
29402 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29403 ELSEIF (IDBJT.EQ.119) THEN
29404 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29408 * heavy fragments (here: fission products only)
29409 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29410 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29411 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29413 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29414 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29418 *------------------------------------------------------------------
29422 **dble Po statistics.
29423 C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29424 C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29425 C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29427 * emulsion treatment
29428 IF (NCOMPO.GT.0) THEN
29430 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29431 & 22X,'----------------------------',/,/,19X,
29432 & 'mass charge fraction',/,39X,
29433 & 'input treated',/)
29435 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29436 & EMUSAM(I)/DBLE(ICEVT)
29437 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29441 * i.n.c. statistics: output
29442 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29443 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29444 & 22X,'---------------------------------',/,/,1X,
29445 & 'no. of events for normalization: (accepted final events,',
29446 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29447 & /,1X,'no. of rejected events due to intranuclear',
29448 & ' cascade',15X,I6,/)
29449 ICEV = MAX(ICEVT,1)
29451 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29453 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29454 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29455 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29456 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29457 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29458 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29459 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29460 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29461 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29462 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29463 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29464 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29465 & /,1X,'maximum no. of generations treated (maximum allowed:'
29466 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29467 & ' interactions in proj./ target (mean per evt1)',
29468 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29469 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29470 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29471 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29472 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29473 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29474 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29475 & 'evaporation',/,22X,'-----------------------------',
29476 & '------------',/,/,1X,'no. of events for normal.: ',
29477 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29478 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29479 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29482 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29483 ICEV = MAX(NRESEV(2),1)
29485 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29486 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29487 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29488 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29489 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29490 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29491 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29492 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29493 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29494 & 'proj. / target',/,/,8X,'total number of particles',15X,
29495 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29496 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29497 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29498 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29499 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29501 * evaporation / fission / fragmentation statistics: output
29502 ICEV = MAX(NRESEV(2),1)
29503 ICEV1 = MAX(NRESEV(4),1)
29505 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29507 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29509 IF (IFISS.EQ.1) CMSG(1) = 'requested '
29510 IF (LFRMBK) CMSG(2) = 'requested '
29511 IF (LDEEXG) CMSG(3) = 'requested '
29514 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29515 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29516 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29517 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29518 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29519 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29520 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29521 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29522 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29523 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29524 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29525 & 'deexcitation:',2X,A13,/,/,
29526 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29527 & 'proj. / target',/,/,8X,'total number of evap. particles',
29528 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29529 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29530 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29531 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29532 & 'heavy fragments',25X,2F9.3,/)
29533 IF (IFISS.EQ.1) THEN
29534 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29535 & NEVAFI(2,1),NEVAFI(2,2),
29536 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29537 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29538 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29539 & 12X,'out of which fission occured',8X,2I9,/,
29540 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29542 C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29544 C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29545 C & ' proj. / target',/)
29547 C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29548 C WRITE(LOUT,3009) I,
29549 C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29550 C3009 FORMAT(38X,I3,3X,2E12.3)
29554 C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29555 C & ' proj. / target',/)
29557 C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29558 C WRITE(LOUT,3011) I,
29559 C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29560 C3011 FORMAT(38X,I3,3X,2E12.3)
29567 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29568 & 'Evaporation: not requested',/)
29572 *------------------------------------------------------------------
29573 * filling of histogram with event-record
29575 * emulsion treatment
29576 IF (NCOMPO.GT.0) THEN
29578 IF (IT.EQ.IEMUMA(I)) THEN
29579 EMUSAM(I) = EMUSAM(I)+ONE
29583 NINCGE = NINCGE+MAXGEN
29585 **dble Po statistics.
29586 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29589 *------------------------------------------------------------------
29590 * filling of histogram with event-record
29592 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29593 IB = IIBAR(IDBAM(IDX))
29594 IC = IICH(IDBAM(IDX))
29596 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29597 NINCST(J,1) = NINCST(J,1)+1
29598 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29599 NINCST(J,2) = NINCST(J,2)+1
29600 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29601 NINCST(J,3) = NINCST(J,3)+1
29602 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29603 NINCST(J,4) = NINCST(J,4)+1
29605 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29606 NINCWO(1) = NINCWO(1)+1
29607 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29608 NINCWO(2) = NINCWO(2)+1
29609 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29613 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29614 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29616 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29622 *$ CREATE DT_NEWHGR.FOR
29625 *===newhgr=============================================================*
29627 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29629 ************************************************************************
29631 * Histogram initialization. *
29633 * input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29635 * IBIN > 0 number of bins in equidistant lin. binning *
29636 * = -1 reset histograms *
29637 * < -1 |IBIN| number of bins in equidistant log. *
29638 * binning or log. binning in user def. struc. *
29639 * XLIMB(*) user defined bin structure *
29641 * The bin structure is sensitive to *
29642 * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29643 * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29644 * XLIMB, IBIN if XLIM3 < 0 *
29647 * output: IREFN histogram index *
29648 * (= -1 for inconsistent histogr. request) *
29650 * This subroutine is based on a original version by R. Engel. *
29651 * This version dated 22.4.95 is written by S. Roesler. *
29652 ************************************************************************
29654 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29656 PARAMETER ( LINP = 10 ,
29662 PARAMETER (ZERO = 0.0D0,
29668 PARAMETER (NHIS=150, NDIM=250)
29669 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29670 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29671 * auxiliary common for histograms
29672 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29674 DATA LSTART /.TRUE./
29676 * reset histogram counter
29677 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29679 IF (IBIN.EQ.-1) RETURN
29684 * check for maximum number of allowed histograms
29685 IF (IHIS.GT.NHIS) THEN
29686 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29687 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29688 & I4,') exceeds array size (',I4,')',/,21X,
29689 & 'histogram',I3,' skipped!')
29694 IBINS(IHIS) = ABS(IBIN)
29695 * check requested number of bins
29696 IF (IBINS(IHIS).GE.NDIM) THEN
29697 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29698 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29699 & I3,') exceeds array size (',I3,')',/,21X,
29700 & 'and will be reset to ',I3)
29703 IF (IBINS(IHIS).EQ.0) THEN
29704 WRITE(LOUT,1001) IBIN,IHIS
29705 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29706 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29710 * initialize arrays
29713 HIST(K,IHIS,I) = ZERO
29714 HIST(K+3,IHIS,I) = ZERO
29715 TMPHIS(K,IHIS,I) = ZERO
29717 HIST(7,IHIS,I) = ZERO
29719 DENTRY(1,IHIS)= ZERO
29720 DENTRY(2,IHIS)= ZERO
29722 UNDERF(IHIS) = ZERO
29723 TMPUFL(IHIS) = ZERO
29724 TMPOFL(IHIS) = ZERO
29726 * bin str. sensitive to lower edge, bin size, and numb. of bins
29727 IF (XLIM3.GT.ZERO) THEN
29728 DO 3 K=1,IBINS(IHIS)+1
29729 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29732 * bin str. sensitive to lower/upper edge and numb. of bins
29733 ELSEIF (XLIM3.EQ.ZERO) THEN
29735 IF (IBIN.GT.0) THEN
29738 IF (XLIM2.LE.XLIM1) THEN
29739 WRITE(LOUT,1002) XLIM1,XLIM2
29740 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29741 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29745 ELSEIF (IBIN.LT.-1) THEN
29746 * logarithmic binning
29747 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29748 WRITE(LOUT,1004) XLIM1,XLIM2
29749 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29750 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29753 IF (XLIM2.LE.XLIM1) THEN
29754 WRITE(LOUT,1005) XLIM1,XLIM2
29755 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29756 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29759 XLOW = LOG10(XLIM1)
29763 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29764 DO 4 K=1,IBINS(IHIS)+1
29765 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29768 * user defined bin structure
29769 DO 5 K=1,IBINS(IHIS)+1
29770 IF (IBIN.GT.0) THEN
29771 HIST(1,IHIS,K) = XLIMB(K)
29773 ELSEIF (IBIN.LT.-1) THEN
29774 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29780 * histogram accepted
29790 *$ CREATE DT_FILHGR.FOR
29793 *===filhgr=============================================================*
29795 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29797 ************************************************************************
29799 * Scoring for histogram IHIS. *
29801 * This subroutine is based on a original version by R. Engel. *
29802 * This version dated 23.4.95 is written by S. Roesler. *
29803 ************************************************************************
29805 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29807 PARAMETER ( LINP = 10 ,
29811 PARAMETER (ZERO = 0.0D0,
29816 PARAMETER (NHIS=150, NDIM=250)
29817 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29818 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29819 * auxiliary common for histograms
29820 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29827 * dump content of temorary arrays into histograms
29828 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29829 CALL DT_EVTHIS(IDUM)
29833 * check histogram index
29834 IF (IHIS.EQ.-1) RETURN
29835 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29836 C WRITE(LOUT,1000) IHIS,IHISL
29837 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29838 & ' out of range (1..',I3,')')
29842 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29843 * bin structure not explicitly given
29844 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29845 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29846 IF (X.LT.HIST(1,IHIS,1)) THEN
29849 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29852 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29853 * user defined bin structure
29854 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29855 IF (X.LT.HIST(1,IHIS,1)) THEN
29857 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29860 * binary sort algorithm
29862 KMAX = IBINS(IHIS)+1
29864 IF ((KMAX-KMIN).EQ.1) GOTO 2
29866 IF (X.LE.HIST(1,IHIS,KK)) THEN
29878 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29884 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29885 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29886 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29887 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29888 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29890 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29892 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29894 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29900 *$ CREATE DT_EVTHIS.FOR
29903 *===evthis=============================================================*
29905 SUBROUTINE DT_EVTHIS(NEVT)
29907 ************************************************************************
29908 * Dump content of temorary histograms into /DTHIS1/. This subroutine *
29909 * is called after each event and for the last event before any call *
29911 * NEVT number of events dumped, this is only needed to *
29912 * get the normalization after the last event *
29913 * This version dated 23.4.95 is written by S. Roesler. *
29914 ************************************************************************
29916 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29918 PARAMETER ( LINP = 10 ,
29924 PARAMETER (ZERO = 0.0D0,
29929 PARAMETER (NHIS=150, NDIM=250)
29930 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29931 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29932 * auxiliary common for histograms
29933 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29943 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29945 HIST(2,I,J) = HIST(2,I,J)+ONE
29946 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29947 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29948 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29949 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29950 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29951 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29952 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29953 TMPHIS(1,I,J) = ZERO
29954 TMPHIS(2,I,J) = ZERO
29955 TMPHIS(3,I,J) = ZERO
29959 IF (TMPUFL(I).GT.ZERO) THEN
29960 UNDERF(I) = UNDERF(I)+ONE
29962 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29963 OVERF(I) = OVERF(I)+ONE
29967 DENTRY(1,I) = DENTRY(1,I)+ONE
29974 *$ CREATE DT_OUTHGR.FOR
29977 *===outhgr=============================================================*
29979 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29980 & ILOGY,INORM,NMODE)
29982 ************************************************************************
29984 * Plot histogram(s) to standard output unit *
29986 * I1..6 indices of histograms to be plotted *
29987 * CHEAD,IHEAD header string,integer *
29988 * NEVTS number of events *
29989 * FAC scaling factor *
29990 * ILOGY = 1 logarithmic y-axis *
29991 * INORM normalization *
29992 * = 0 no further normalization (FAC is obsolete) *
29993 * = 1 per event and bin width *
29994 * = 2 per entry and bin width *
29995 * = 3 per bin entry *
29996 * = 4 per event and "bin width" x1^2...x2^2 *
29997 * = 5 per event and "log. bin width" ln x1..ln x2 *
29999 * MODE = 0 no output but normalization applied *
30000 * = 1 all valid histograms separately (small frame) *
30001 * all valid histograms separately (small frame) *
30002 * = -1 and tables as histograms *
30003 * = 2 all valid histograms (one plot, wide frame) *
30004 * all valid histograms (one plot, wide frame) *
30005 * = -2 and tables as histograms *
30008 * Note: All histograms to be plotted with one call to this *
30009 * subroutine and |MODE|=2 must have the same bin structure! *
30010 * There is no test included ensuring this fact. *
30012 * This version dated 23.4.95 is written by S. Roesler. *
30013 ************************************************************************
30015 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30017 PARAMETER ( LINP = 10 ,
30023 PARAMETER (ZERO = 0.0D0,
30034 PARAMETER (NHIS=150, NDIM=250)
30035 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30036 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30038 PARAMETER (NDIM2 = 2*NDIM)
30039 DIMENSION XX(NDIM2),YY(NDIM2)
30041 PARAMETER (NHISTO = 6)
30042 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30045 CHARACTER*43 CNORM(0:8)
30046 DATA CNORM /'no further normalization ',
30047 & 'per event and bin width ',
30048 & 'per entry1 and bin width ',
30049 & 'per bin entry ',
30050 & 'per event and "bin width" x1^2...x2^2 ',
30051 & 'per event and "log. bin width" ln x1..ln x2',
30053 & 'per bin entry1 ',
30054 & 'per entry2 and bin width '/
30065 * initialization if "wide frame" is requested
30066 IF (ABS(MODE).EQ.2) THEN
30076 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30078 * check histogram indices
30081 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30082 IF (ISWI(IDX1(I)).NE.0) THEN
30083 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30085 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30086 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
30087 & ' histogram ',I3,/,21X,'underflows:',F10.0,
30088 & ' overflows: ',F10.0)
30098 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30102 * check normalization request
30103 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30104 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30105 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30106 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30107 WRITE(LOUT,1002) NEVTS,INORM,FAC
30108 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30109 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30114 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30116 * apply normalization
30121 IF (ISWI(I).EQ.1) THEN
30122 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30123 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30124 & ' to',2X,E10.4,',',2X,I3,' bins')
30125 ELSEIF (ISWI(I).EQ.2) THEN
30126 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30128 1007 FORMAT(1X,'user defined bin structure')
30129 ELSEIF (ISWI(I).EQ.3) THEN
30131 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30132 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30133 & ' to',2X,E10.4,',',2X,I3,' bins')
30134 ELSEIF (ISWI(I).EQ.4) THEN
30136 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30139 WRITE(LOUT,1008) ISWI(I)
30140 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30142 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30143 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30144 & ' overfl.:',F8.0)
30145 WRITE(LOUT,1009) CNORM(INORM)
30146 1009 FORMAT(1X,'normalization: ',A,/)
30149 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30152 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30153 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30154 1006 FORMAT(1X,5E11.3)
30157 XX(II-1) = HIST(1,I,K)
30158 XX(II) = HIST(1,I,K+1)
30163 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30164 & XX1(K,N) = LOG10(XMEAN)
30169 IF (ABS(MODE).EQ.1) THEN
30171 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30172 IF(ILOGY.EQ.1) THEN
30173 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30175 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30182 IF (ABS(MODE).EQ.2) THEN
30183 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30184 NSIZE = NDIM*NHISTO
30185 DXLOW = HIST(1,IDX(1),1)
30186 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30191 IF (YY1(J,I).LT.YLOW) THEN
30192 IF (ILOGY.EQ.1) THEN
30193 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30198 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30201 DY = (YHI-YLOW)/DBLE(NDIM)
30202 IF (DY.LE.ZERO) THEN
30203 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30204 & 'OUTHGR: warning! zero bin width for histograms ',
30205 & IDX,': ',YLOW,YHI
30208 IF (ILOGY.EQ.1) THEN
30210 DY = (LOG10(YHI)-YLOW)/100.0D0
30213 IF (YY1(J,I).LE.ZERO) THEN
30216 YY1(J,I) = LOG10(YY1(J,I))
30221 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30227 *$ CREATE DT_GETBIN.FOR
30230 *===getbin=============================================================*
30232 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30233 & XMEAN,YMEAN,YERR)
30235 ************************************************************************
30236 * This version dated 23.4.95 is written by S. Roesler. *
30237 ************************************************************************
30239 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30241 PARAMETER ( LINP = 10 ,
30245 PARAMETER (ZERO = 0.0D0,
30247 & TINY35 = 1.0D-35)
30250 PARAMETER (NHIS=150, NDIM=250)
30251 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30252 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30254 XLOW = HIST(1,IHIS,IBIN)
30255 XHI = HIST(1,IHIS,IBIN+1)
30256 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30260 IF (NORM.EQ.2) THEN
30262 NEVT = INT(DENTRY(1,IHIS))
30263 ELSEIF (NORM.EQ.3) THEN
30265 NEVT = INT(HIST(2,IHIS,IBIN))
30266 ELSEIF (NORM.EQ.4) THEN
30267 DX = XHI**2-XLOW**2
30269 ELSEIF (NORM.EQ.5) THEN
30270 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30272 ELSEIF (NORM.EQ.6) THEN
30275 ELSEIF (NORM.EQ.7) THEN
30277 NEVT = INT(HIST(7,IHIS,IBIN))
30278 ELSEIF (NORM.EQ.8) THEN
30280 NEVT = INT(DENTRY(2,IHIS))
30285 IF (ABS(DX).LT.TINY35) DX = ONE
30287 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30288 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30289 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30290 YSUM = HIST(5,IHIS,IBIN)
30291 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30292 C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30293 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30294 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30299 *$ CREATE DT_JOIHIS.FOR
30302 *===joihis=============================================================*
30304 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30306 ************************************************************************
30308 * Operation on histograms. *
30310 * input: IH1,IH2 histogram indices to be joined *
30311 * COPER character defining the requested operation, *
30312 * i.e. '+', '-', '*', '/' *
30313 * FAC1,FAC2 factors for joining, i.e. *
30314 * FAC1*histo1 COPER FAC2*histo2 *
30316 * This version dated 23.4.95 is written by S. Roesler. *
30317 ************************************************************************
30319 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30321 PARAMETER ( LINP = 10 ,
30327 PARAMETER (ZERO = 0.0D0,
30335 PARAMETER (NHIS=150, NDIM=250)
30336 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30337 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30339 PARAMETER (NDIM2 = 2*NDIM)
30340 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30342 CHARACTER*43 CNORM(0:6)
30343 DATA CNORM /'no further normalization ',
30344 & 'per event and bin width ',
30345 & 'per entry and bin width ',
30346 & 'per bin entry ',
30347 & 'per event and "bin width" x1^2...x2^2 ',
30348 & 'per event and "log. bin width" ln x1..ln x2',
30351 * check histogram indices
30352 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30353 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30354 WRITE(LOUT,1000) IH1,IH2,IHISL
30355 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30356 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30360 * check bin structure of histograms to be joined
30361 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30362 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30363 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30364 & ' and ',I3,' failed',/,21X,
30365 & 'due to different numbers of bins (',I3,',',I3,')')
30368 DO 1 K=1,IBINS(IH1)+1
30369 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30370 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30371 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30372 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30373 & 'X1,X2 = ',2E11.4)
30378 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30379 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30380 & 'operation ',A,/,11X,'and factors ',2E11.4)
30381 WRITE(LOUT,1004) CNORM(NORM)
30382 1004 FORMAT(1X,'normalization: ',A,/)
30384 DO 2 K=1,IBINS(IH1)
30385 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30386 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30389 XMEAN = OHALF*(XMEAN1+XMEAN2)
30390 IF (COPER.EQ.'+') THEN
30391 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30392 ELSEIF (COPER.EQ.'*') THEN
30393 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30394 ELSEIF (COPER.EQ.'/') THEN
30395 IF (YMEAN2.EQ.ZERO) THEN
30398 IF (FAC2.EQ.ZERO) FAC2 = ONE
30399 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30404 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30405 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30406 1006 FORMAT(1X,5E11.3)
30409 XX(II-1) = HIST(1,IH1,K)
30410 XX(II) = HIST(1,IH1,K+1)
30415 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30420 IF (ABS(MODE).EQ.1) THEN
30421 IBIN2 = 2*IBINS(IH1)
30422 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30423 IF(ILOGY.EQ.1) THEN
30424 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30426 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30431 IF (ABS(MODE).EQ.2) THEN
30432 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30434 DXLOW = HIST(1,IH1,1)
30435 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30439 IF (YY1(I).LT.YLOW) THEN
30440 IF (ILOGY.EQ.1) THEN
30441 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30446 IF (YY1(I).GT.YHI) YHI = YY1(I)
30448 DY = (YHI-YLOW)/DBLE(NDIM)
30449 IF (DY.LE.ZERO) THEN
30450 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30451 & 'JOIHIS: warning! zero bin width for histograms ',
30452 & IH1,IH2,': ',YLOW,YHI
30455 IF (ILOGY.EQ.1) THEN
30457 DY = (LOG10(YHI)-YLOW)/100.0D0
30459 IF (YY1(I).LE.ZERO) THEN
30462 YY1(I) = LOG10(YY1(I))
30466 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30472 WRITE(LOUT,1005) COPER
30473 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30479 *$ CREATE DT_XGRAPH.FOR
30482 *===qgraph=============================================================*
30484 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30485 C***********************************************************************
30487 C calculate quasi graphic picture with 25 lines and 79 columns
30488 C ranges will be chosen automatically
30490 C input N dimension of input fields
30491 C IARG number of curves (fields) to plot
30496 C This subroutine is written by R. Engel.
30497 C***********************************************************************
30498 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30501 PARAMETER ( LINP = 10 ,
30505 DIMENSION X(N),Y1(N),Y2(N)
30506 PARAMETER (EPS=1.D-30)
30507 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30509 CHARACTER COL(0:149,0:49)
30511 DATA SYMB /'0','e','z','#','x'/
30515 C*** automatic range fitting
30520 XMAX=MAX(X(I),XMAX)
30521 XMIN=MIN(X(I),XMIN)
30523 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30526 DO 1100 K=0,IZEIL-1
30528 IF (ITEST.EQ.IYRAST) THEN
30529 DO 1010 L=1,ISPALT-1
30534 DO 1020 L=0,ISPALT-1,IXRAST
30538 DO 1030 L=1,ISPALT-1
30541 DO 1040 L=0,ISPALT-1,IXRAST
30553 YMAX=MAX(Y1(I),YMAX)
30554 YMIN=MIN(Y1(I),YMIN)
30558 YMAX=MAX(Y2(I),YMAX)
30559 YMIN=MIN(Y2(I),YMIN)
30562 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30563 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30564 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30565 IF(YZOOM.LT.EPS) THEN
30566 WRITE(LOUT,'(1X,A)')
30567 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30576 L=NINT((X(K)-XMIN)/XZOOM)
30577 I=NINT((YMAX-Y1(K))/YZOOM)
30578 IF(ILAST.GE.0) THEN
30581 DO 55 II=0,LD,SIGN(1,LD)
30582 DO 66 KK=0,ID,SIGN(1,ID)
30583 COL(II+LLAST,KK+ILAST)=SYMB(1)
30598 L=NINT((X(K)-XMIN)/XZOOM)
30599 I=NINT((YMAX-Y2(K))/YZOOM)
30606 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30608 C*** write range of X
30610 XZOOM = (XMAX-XMIN)/DBLE(7)
30611 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30613 DO 1300 K=0,IZEIL-1
30614 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30615 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30616 110 FORMAT(1X,1PE9.2,70A1)
30619 C*** write range of X
30621 XZOOM = (XMAX-XMIN)/DBLE(7)
30622 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30623 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30624 120 FORMAT(6X,7(1PE10.3))
30627 *$ CREATE DT_XGLOGY.FOR
30630 *===qglogy=============================================================*
30632 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30633 C***********************************************************************
30635 C calculate quasi graphic picture with 25 lines and 79 columns
30636 C logarithmic y axis
30637 C ranges will be chosen automatically
30639 C input N dimension of input fields
30640 C IARG number of curves (fields) to plot
30645 C This subroutine is written by R. Engel.
30646 C***********************************************************************
30648 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30651 PARAMETER ( LINP = 10 ,
30654 DIMENSION X(N),Y1(N),Y2(N)
30655 PARAMETER (EPS=1.D-30)
30656 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30658 CHARACTER COL(0:149,0:49)
30659 PARAMETER (DEPS = 1.D-10)
30661 DATA SYMB /'0','e','z','#','x'/
30665 C*** automatic range fitting
30670 XMAX=MAX(X(I),XMAX)
30671 XMIN=MIN(X(I),XMIN)
30673 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30676 DO 1100 K=0,IZEIL-1
30678 IF (ITEST.EQ.IYRAST) THEN
30679 DO 1010 L=1,ISPALT-1
30684 DO 1020 L=0,ISPALT-1,IXRAST
30688 DO 1030 L=1,ISPALT-1
30691 DO 1040 L=0,ISPALT-1,IXRAST
30701 YMIN=MAX(Y1(1),EPS)
30703 YMAX =MAX(Y1(I),YMAX)
30704 IF(Y1(I).GT.EPS) THEN
30705 IF(YMIN.EQ.EPS) THEN
30708 YMIN = MIN(Y1(I),YMIN)
30714 YMAX=MAX(Y2(I),YMAX)
30715 IF(Y2(I).GT.EPS) THEN
30716 IF(YMIN.EQ.EPS) THEN
30719 YMIN = MIN(Y2(I),YMIN)
30726 Y1(I) = MAX(Y1(I),YMIN)
30730 Y2(I) = MAX(Y2(I),YMIN)
30734 IF(YMAX.LE.YMIN) THEN
30735 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30736 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30737 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30741 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30742 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30743 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30744 IF(YZOOM.LT.EPS) THEN
30745 WRITE(LOUT,'(1X,A)')
30746 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30755 L=NINT((X(K)-XMIN)/XZOOM)
30756 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30757 IF(ILAST.GE.0) THEN
30760 DO 55 II=0,LD,SIGN(1,LD)
30761 DO 66 KK=0,ID,SIGN(1,ID)
30762 COL(II+LLAST,KK+ILAST)=SYMB(1)
30777 L=NINT((X(K)-XMIN)/XZOOM)
30778 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30785 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30786 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30788 C*** write range of X
30790 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30791 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30793 DO 1300 K=0,IZEIL-1
30794 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30795 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30796 110 FORMAT(1X,1PE9.2,70A1)
30799 C*** write range of X
30801 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30802 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30803 120 FORMAT(6X,7(1PE10.3))
30807 *$ CREATE DT_SRPLOT.FOR
30810 *===plot===============================================================*
30812 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30814 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30817 PARAMETER ( LINP = 10 ,
30822 * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30823 * This is a subroutine of fluka to plot Y across the page
30824 * as a function of X down the page. Up to 37 curves can be
30825 * plotted in the same picture with different plotting characters.
30826 * Output of first 10 overprinted characters addad by FB 88
30827 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30830 * X = array containing the values of X
30831 * Y = array containing the values of Y
30832 * N = number of values in X and in Y
30833 * can exceed the fixed number of lines
30834 * M = number of different curves X,Y are containing
30835 * MM = number of points in each curve i.e. N=M*MM
30836 * XO = smallest value of X to be plotted
30837 * DX = increment of X between subsequent lines
30838 * YO = smallest value of Y to be plotted
30839 * DY = increment of Y between subsequent character spaces
30841 * other variables used inside:
30842 * XX = numbers along the X-coordinate axis
30843 * YY = numbers along the Y-coordinate axis
30844 * LL = ten lines temporary storage for the plot
30845 * L = character set used to plot different curves
30846 * LOV = memorizes overprinted symbols
30847 * the first 10 overprinted symbols are printed on
30848 * the end of the line to avoid ambiguities
30849 * (added by FB as considered quite helpful)
30851 *********************************************************************
30853 DIMENSION XX(61),YY(61),LL(101,10)
30854 DIMENSION X(N),Y(N),L(40),LOV(40,10)
30855 INTEGER*4 LL, L, LOV
30857 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30858 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30859 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30860 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30869 20 YY(I)=YO+10.0D0*AI*DY
30870 WRITE(LOUT, 500) (YY(I),I=1,11)
30892 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30893 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30895 * changed Sept.88 by FB to avoid INTEGER OVERFLOW
30896 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30897 + . AIY .LT. 102.D0) THEN
30900 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30902 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30913 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30914 & (LOV(J,I),J=1,10)
30920 WRITE(LOUT, 500) (YY(I),I=1,11)
30923 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30924 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30925 520 FORMAT(20X,10('1---------'),'1')
30928 *$ CREATE DT_DEFSET.FOR
30931 *===defset=============================================================*
30933 BLOCK DATA DT_DEFSET
30935 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30938 * flags for input different options
30939 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30940 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30941 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30942 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30943 * emulsion treatment
30944 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30948 DATA IFRAG / 2, 1 /
30952 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30953 DATA LEMCCK / .FALSE. /
30954 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30955 & .TRUE.,.TRUE.,.TRUE./
30956 DATA LSEADI / .TRUE. /
30957 DATA LEVAPO / .TRUE. /
30962 DATA EMUFRA / NCOMPX*0.0D0 /
30963 DATA IEMUMA / NCOMPX*1 /
30964 DATA IEMUCH / NCOMPX*1 /
30970 *$ CREATE DT_HADPRP.FOR
30973 *===hadprp=============================================================*
30975 BLOCK DATA DT_HADPRP
30977 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30980 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30981 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30982 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30983 & IQTCHR(-6:6),MQUARK(3,39)
30984 * hadron index conversion (BAMJET <--> PDG)
30985 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30986 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30988 * names of hadrons used in input-cards
30990 COMMON /DTPAIN/ BTYPE(30)
30993 *----------------------------------------------------------------------*
30995 * Quark content of particles: *
30996 * index quark el. charge bar. charge isospin isospin3 *
30997 * 1 = u 2/3 1/3 1/2 1/2 *
30998 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
30999 * 2 = d -1/3 1/3 1/2 -1/2 *
31000 * -2 = dbar 1/3 -1/3 1/2 1/2 *
31001 * 3 = s -1/3 1/3 0 0 *
31002 * -3 = sbar 1/3 -1/3 0 0 *
31003 * 4 = c 2/3 1/3 0 0 *
31004 * -4 = cbar -2/3 -1/3 0 0 *
31005 * 5 = b -1/3 1/3 0 0 *
31006 * -5 = bbar 1/3 -1/3 0 0 *
31007 * 6 = t 2/3 1/3 0 0 *
31008 * -6 = tbar -2/3 -1/3 0 0 *
31010 * Mquark = particle quark composition (Paprop numbering) *
31011 * Iqechr = electric charge ( in 1/3 unit ) *
31012 * Iqbchr = baryonic charge ( in 1/3 unit ) *
31013 * Iqichr = isospin ( in 1/2 unit ), z component *
31014 * Iqschr = strangeness *
31016 * Iquchr = beauty *
31017 * Iqtchr = ...... *
31019 *----------------------------------------------------------------------*
31020 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
31021 DATA IQBCHR / 6*-1, 0, 6*1 /
31022 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
31023 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
31024 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
31025 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
31026 DATA IQTCHR / -1, 11*0, 1 /
31028 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31029 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
31030 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
31031 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
31032 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
31033 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31034 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
31035 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
31038 * (renamed) (HAdron InDex COnversion)
31039 * translation table version filled up by r.e. 25.01.94 *
31041 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
31042 &13,130,211,-211,321, -321,3122,-3122,310,3112,
31043 &3222,3212,111,311,-311, 0,0,0,0,0,
31044 &221,213,113,-213,223, 323,313,-323,-313,10323,
31045 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
31046 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
31047 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
31048 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31050 &4*99999,331, 333,3322,3312,-3222,-3212,
31051 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
31052 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
31053 &-431,441,423,413,-413, -423,433,-433,20443,443,
31054 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
31055 &4212,4112,3*99999, 3*99999,-4122,-4232,
31056 &-4132,-4222,-4212,-4112,99999, 5*99999,
31059 &5*99999 , 20211,20111,-20211,99999,20321,
31060 &-20321,20311,-20311,7*99999 ,
31061 &7*99999,12212,12112,99999/
31064 * (HAdron InDex COnversion)
31065 DATA (IPDG2(1,K),K=1,7)
31066 & / -11, -12, -13, -15, -16, -14, 0/
31067 DATA (IBAM2(1,K),K=1,7)
31068 & / 4, 6, 10, 131, 134, 136, 0/
31069 DATA (IPDG2(2,K),K=1,7)
31070 & / 11, 12, 22, 13, 15, 16, 14/
31071 DATA (IBAM2(2,K),K=1,7)
31072 & / 3, 5, 7, 11, 132, 133, 135/
31073 DATA (IPDG3(1,K),K=1,22)
31074 & / -211, -321, -311, -213, -323, -313, -411, -421,
31075 & -431, -413, -423, -433, 0, 0, 0, 0,
31076 & 0, 0, 0, 0, 0, 0/
31077 DATA (IBAM3(1,K),K=1,22)
31078 & / 14, 16, 25, 34, 38, 39, 118, 119,
31079 & 121, 125, 126, 128, 0, 0, 0, 0,
31080 & 0, 0, 0, 0, 0, 0/
31081 DATA (IPDG3(2,K),K=1,22)
31082 & / 130, 211, 321, 310, 111, 311, 221, 213,
31083 & 113, 223, 323, 313, 331, 333, 421, 411,
31084 & 431, 441, 423, 413, 433, 443/
31085 DATA (IBAM3(2,K),K=1,22)
31086 & / 12, 13, 15, 19, 23, 24, 31, 32,
31087 & 33, 35, 36, 37, 95, 96, 116, 117,
31088 & 120, 122, 123, 124, 127, 130/
31089 DATA (IPDG4(1,K),K=1,29)
31090 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31091 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31092 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31093 & -4212, -4112, 0, 0, 0/
31094 DATA (IBAM4(1,K),K=1,29)
31095 & / 2, 9, 18, 67, 68, 69, 70, 75,
31096 & 76, 99, 100, 101, 102, 103, 110, 111,
31097 & 112, 113, 114, 115, 149, 150, 151, 152,
31098 & 153, 154, 0, 0, 0/
31099 DATA (IPDG4(2,K),K=1,29)
31100 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31101 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31102 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31103 & 4232, 4132, 4222, 4212, 4112/
31104 DATA (IBAM4(2,K),K=1,29)
31105 & / 1, 8, 17, 20, 21, 22, 48, 49,
31106 & 50, 51, 52, 53, 54, 55, 56, 97,
31107 & 98, 104, 105, 106, 107, 108, 109, 137,
31108 & 138, 139, 140, 141, 142/
31109 DATA (IPDG5(1,K),K=1,19)
31110 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31111 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31113 DATA (IBAM5(1,K),K=1,19)
31114 & / 42, 43, 46, 47, 71, 72, 73, 74,
31115 & 188, 191, 193, 0, 0, 0, 0, 0,
31117 DATA (IPDG5(2,K),K=1,19)
31118 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31119 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31120 & 20311, 12212, 12112/
31121 DATA (IBAM5(2,K),K=1,19)
31122 & / 40, 41, 44, 45, 57, 58, 59, 60,
31123 & 63, 64, 65, 66, 129, 186, 187, 190,
31127 * internal particle names
31128 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31129 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31130 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31131 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31132 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31133 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31138 *$ CREATE DT_BLKD46.FOR
31141 *===blkd46=============================================================*
31143 BLOCK DATA DT_BLKD46
31145 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31148 PARAMETER ( AMELCT = 0.51099906 D-03 )
31149 PARAMETER ( AMMUON = 0.105658389 D+00 )
31151 * particle properties (BAMJET index convention)
31153 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31154 & IICH(210),IIBAR(210),K1(210),K2(210)
31157 * Particle masses Engel version JETSET compatible
31158 C DATA (AAM(K),K=1,85) /
31159 C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31160 C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31161 C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31162 C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31163 C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31164 C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31165 C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31166 C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31167 C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31168 C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31169 C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31170 C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31171 C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31172 C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31173 C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31174 C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31175 C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31176 C DATA (AAM(K),K=86,183) /
31177 C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31178 C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31179 C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31180 C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31181 C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31182 C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31183 C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31184 C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31185 C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31186 C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31187 C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31188 C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31189 C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31190 C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31191 C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31192 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31193 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31194 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31195 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31196 C & .1250D+01, .1250D+01, .1250D+01 /
31197 C DATA (AAM ( I ), I = 184,210 ) /
31198 C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31199 C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31200 C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31201 C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31202 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31203 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31204 C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31205 C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31206 C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31207 * sr 25.1.06: particle masses adjusted to Pythia
31208 DATA (AAM(K),K=1,85) /
31209 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31210 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31211 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31212 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31213 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31214 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31215 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31216 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31217 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31218 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31219 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31220 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31221 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31222 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31223 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31224 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31225 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31226 DATA (AAM(K),K=86,183) /
31227 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31228 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31229 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31230 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31231 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31232 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31233 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31234 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31235 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31236 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31237 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31238 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31239 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31240 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31241 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31242 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31243 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31244 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31245 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31246 & .1250D+01, .1250D+01, .1250D+01 /
31247 DATA (AAM ( I ), I = 184,210 ) /
31248 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31249 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31250 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31251 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31252 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31253 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31254 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31255 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31256 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31257 * Particle mean lives
31258 DATA (TAU(K),K=1,183) /
31259 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31260 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31261 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31262 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31263 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31265 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31266 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31267 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31268 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31269 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31270 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31271 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31272 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31273 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31275 & .0000D+00, .0000D+00, .0000D+00 /
31276 DATA ( TAU ( I ), I = 184,210 ) /
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 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31282 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31283 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31284 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31285 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31286 * Resonance width Gamma in GeV
31287 DATA (GA(K),K= 1,85) /
31289 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31290 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31291 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31292 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31293 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31294 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31295 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31296 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31297 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31298 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31299 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31300 DATA (GA(K),K= 86,183) /
31301 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31302 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31303 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31304 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31305 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31306 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31307 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31308 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31309 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31311 & .3000D+00, .3000D+00, .3000D+00 /
31312 DATA ( GA ( I ), I = 184,210 ) /
31313 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31314 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31315 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31316 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31317 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31318 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31319 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31320 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31321 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31323 * S+1385+Sigma+(1385) L02030+Lambda0(2030)
31324 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31325 * designation N*@@ means N*@1(@2)
31326 DATA (ANAME(K),K=1,85) /
31327 & 'P ','AP ','E- ','E+ ','NUE ',
31328 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31329 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31330 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31331 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31332 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31333 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31334 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31335 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31336 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31337 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31338 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31339 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31340 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31341 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31342 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31343 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31344 DATA (ANAME(K),K=86,183) /
31345 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31346 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31347 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31348 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31349 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31350 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31351 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31352 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31353 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31354 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31355 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31356 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31357 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31358 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31359 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31360 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31361 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31362 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31363 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31364 & 'RO ','R+ ','R- ' /
31365 DATA ( ANAME ( I ), I = 184,210 ) /
31366 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31367 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31368 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31369 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31370 &'N*+14 ','N*014 ','BLANK '/
31371 * Charge of particles and resonances
31372 DATA (IICH ( I ), I = 1,210 ) /
31373 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31374 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31375 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31376 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31377 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31378 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31379 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31380 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31381 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31382 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31383 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31384 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31385 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31386 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31387 * Particle baryonic charges
31388 DATA (IIBAR ( I ), I = 1,210 ) /
31389 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31390 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31391 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31392 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31393 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31394 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31395 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31396 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31397 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31398 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31399 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31400 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31401 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31402 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31403 * First number of decay channels used for resonances
31404 * and decaying particles
31405 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31406 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31407 & 2*330, 46, 51, 52, 54, 55, 58,
31409 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31410 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31411 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31413 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31414 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31415 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31416 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31417 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31418 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31419 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31420 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31421 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31422 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31424 * Last number of decay channels used for resonances
31425 * and decaying particles
31426 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31427 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31428 & 2* 330, 50, 51, 53, 54, 57,
31430 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31431 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31432 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31434 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31435 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31436 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31437 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31438 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31439 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31440 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31441 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31442 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31443 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31444 & 589, 595, 601, 602 /
31448 *$ CREATE DT_BLKD47.FOR
31451 *===blkd47=============================================================*
31453 BLOCK DATA DT_BLKD47
31455 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31458 * HADRIN: decay channel information
31459 PARAMETER (IDMAX9=602)
31461 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31463 * Name of decay channel
31464 * Designation N*@ means N*@1(1236)
31465 * @1=# means ++, @1 = = means --
31466 * Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31467 DATA (ZKNAME(K),K= 1, 85) /
31468 & 'P ','AP ','E- ','E+ ','NUE ',
31469 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31470 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31471 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31472 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31473 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31474 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31475 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31476 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31477 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31478 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31479 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31480 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31481 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31482 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31483 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31484 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31485 DATA (ZKNAME(K),K= 86,170) /
31486 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31487 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31488 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31489 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31490 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31491 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31492 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31493 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31494 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31495 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31496 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31497 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31498 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31499 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31500 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31501 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31502 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31503 DATA (ZKNAME(K),K=171,255) /
31504 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31505 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31506 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31507 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31508 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31509 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31510 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31511 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31512 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31513 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31514 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31515 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31516 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31517 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31518 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31519 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31520 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31521 DATA (ZKNAME(K),K=256,340) /
31522 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31523 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31524 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31525 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31526 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31527 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31528 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31529 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31530 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31531 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31532 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31533 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31534 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31535 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31536 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31537 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31538 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31539 DATA (ZKNAME(K),K=341,425) /
31540 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31541 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31542 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31543 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31544 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31545 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31546 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31547 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31548 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31549 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31550 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31551 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31552 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31553 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31554 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31555 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31556 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31557 DATA (ZKNAME(K),K=426,510) /
31558 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31559 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31560 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31561 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31562 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31563 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31564 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31565 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31566 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31567 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31568 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31569 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31570 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31571 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31572 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31573 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31574 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31575 DATA (ZKNAME(K),K=511,540) /
31576 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31577 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31578 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31579 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31580 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31581 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31582 DATA (ZKNAME(I),I=541,602)/
31583 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31584 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31585 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31586 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31587 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31588 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31589 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31590 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31591 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31592 * Weight of decay channel
31593 DATA (WT(K),K= 1, 85) /
31594 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31595 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31596 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31597 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31598 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31599 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31600 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31601 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31602 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31603 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31604 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31605 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31606 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31607 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31608 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31609 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31610 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31611 DATA (WT(K),K= 86,170) /
31612 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31613 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31614 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31615 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31616 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31617 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31618 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31619 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31620 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31621 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31622 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31623 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31624 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31625 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31626 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31627 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31628 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31629 DATA (WT(K),K=171,255) /
31630 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31631 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31632 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31633 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31634 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31635 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31636 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31637 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31638 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31639 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31640 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31641 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31642 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31643 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31644 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31645 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31646 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31647 DATA (WT(K),K=256,340) /
31648 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31649 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31650 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31651 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31652 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31653 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31654 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31655 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31656 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31657 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31658 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31659 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31660 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31661 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31662 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31663 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31664 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31665 DATA (WT(K),K=341,425) /
31666 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31667 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31668 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31669 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31670 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31671 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31672 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31673 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31674 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31675 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31676 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31677 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31678 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31679 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31680 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31681 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31682 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31683 DATA (WT(K),K=426,510) /
31684 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31685 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31686 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31687 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31688 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31689 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31690 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31691 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31692 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31693 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31694 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31695 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31696 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31697 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31698 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31699 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31700 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31701 DATA (WT(K),K=511,540) /
31702 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31703 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31704 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31705 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31706 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31707 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31709 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31710 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31711 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31712 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31713 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31714 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31715 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31716 * Particle numbers in decay channel
31717 DATA (NZK(K,1),K= 1,170) /
31718 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31719 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31720 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31721 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31722 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31723 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31724 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31725 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31726 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31727 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31728 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31729 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31730 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31731 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31732 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31733 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31734 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31735 DATA (NZK(K,1),K=171,340) /
31736 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31737 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31738 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31739 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31740 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31741 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31742 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31743 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31744 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31745 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31746 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31747 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31748 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31749 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31750 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31751 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31752 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31753 DATA (NZK(K,1),K=341,510) /
31754 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31755 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31756 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31757 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31758 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31759 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31760 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31761 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31762 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31763 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31764 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31765 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31766 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31767 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31768 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31769 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31770 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31771 DATA (NZK(K,1),K=511,540) /
31772 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31773 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31774 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31775 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31776 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31777 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31778 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31779 & 55, 8, 1, 8, 8, 54, 55, 210/
31780 DATA (NZK(K,2),K= 1,170) /
31781 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31782 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31783 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31784 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31785 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31786 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31787 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31788 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31789 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31790 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31791 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31792 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31793 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31794 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31795 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31796 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31797 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31798 DATA (NZK(K,2),K=171,340) /
31799 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31800 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31801 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31802 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31803 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31804 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31805 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31806 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31807 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31808 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31809 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31810 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31811 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31812 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31813 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31814 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31815 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31816 DATA (NZK(K,2),K=341,510) /
31817 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31818 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31819 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31820 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31821 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31822 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31823 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31824 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31825 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31826 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31827 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31828 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31829 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31830 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31831 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31832 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31833 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31834 DATA (NZK(K,2),K=511,540) /
31835 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31836 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31837 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31838 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31839 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31840 & 14, 14, 23, 14, 16, 25,
31841 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31842 & 23, 13, 14, 23, 0 /
31843 DATA (NZK(K,3),K= 1,170) /
31844 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31845 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31846 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31847 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31848 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31849 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31851 DATA (NZK(K,3),K=171,340) /
31853 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31854 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31855 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31856 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31857 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31859 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31860 DATA (NZK(K,3),K=341,510) /
31862 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31863 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31864 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31865 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31866 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31867 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31869 DATA (NZK(K,3),K=511,540) /
31870 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31871 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31872 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31873 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31874 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31878 *$ CREATE DT_BDEVAP.FOR
31881 *=== bdevap ===========================================================*
31883 BLOCK DATA DT_BDEVAP
31885 C INCLUDE '(DBLPRC)'
31887 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31889 * (original name: GLOBAL)
31890 PARAMETER ( KALGNM = 2 )
31891 PARAMETER ( ANGLGB = 5.0D-16 )
31892 PARAMETER ( ANGLSQ = 2.5D-31 )
31893 PARAMETER ( AXCSSV = 0.2D+16 )
31894 PARAMETER ( ANDRFL = 1.0D-38 )
31895 PARAMETER ( AVRFLW = 1.0D+38 )
31896 PARAMETER ( AINFNT = 1.0D+30 )
31897 PARAMETER ( AZRZRZ = 1.0D-30 )
31898 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31899 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31900 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31901 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31902 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
31903 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
31904 PARAMETER ( CSNNRM = 2.0D-15 )
31905 PARAMETER ( DMXTRN = 1.0D+08 )
31906 PARAMETER ( ZERZER = 0.D+00 )
31907 PARAMETER ( ONEONE = 1.D+00 )
31908 PARAMETER ( TWOTWO = 2.D+00 )
31909 PARAMETER ( THRTHR = 3.D+00 )
31910 PARAMETER ( FOUFOU = 4.D+00 )
31911 PARAMETER ( FIVFIV = 5.D+00 )
31912 PARAMETER ( SIXSIX = 6.D+00 )
31913 PARAMETER ( SEVSEV = 7.D+00 )
31914 PARAMETER ( EIGEIG = 8.D+00 )
31915 PARAMETER ( ANINEN = 9.D+00 )
31916 PARAMETER ( TENTEN = 10.D+00 )
31917 PARAMETER ( HLFHLF = 0.5D+00 )
31918 PARAMETER ( ONETHI = ONEONE / THRTHR )
31919 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31920 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31921 PARAMETER ( THRTWO = THRTHR / TWOTWO )
31922 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31923 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31924 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31925 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31926 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31927 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31928 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31929 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
31930 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
31931 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
31932 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
31933 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31934 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31935 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31936 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31937 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31938 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31939 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31940 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31941 PARAMETER ( CLIGHT = 2.99792458 D+10 )
31942 PARAMETER ( AVOGAD = 6.0221367 D+23 )
31943 PARAMETER ( BOLTZM = 1.380658 D-23 )
31944 PARAMETER ( AMELGR = 9.1093897 D-28 )
31945 PARAMETER ( PLCKBR = 1.05457266 D-27 )
31946 PARAMETER ( ELCCGS = 4.8032068 D-10 )
31947 PARAMETER ( ELCMKS = 1.60217733 D-19 )
31948 PARAMETER ( AMUGRM = 1.6605402 D-24 )
31949 PARAMETER ( AMMUMU = 0.113428913 D+00 )
31950 PARAMETER ( AMPRMU = 1.007276470 D+00 )
31951 PARAMETER ( AMNEMU = 1.008664904 D+00 )
31952 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31953 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31954 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31955 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31956 PARAMETER ( PLABRC = 0.197327053 D+00 )
31957 PARAMETER ( AMELCT = 0.51099906 D-03 )
31958 PARAMETER ( AMUGEV = 0.93149432 D+00 )
31959 PARAMETER ( AMMUON = 0.105658389 D+00 )
31960 PARAMETER ( AMPRTN = 0.93827231 D+00 )
31961 PARAMETER ( AMNTRN = 0.93956563 D+00 )
31962 PARAMETER ( AMDEUT = 1.87561339 D+00 )
31963 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31965 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31966 PARAMETER ( BLTZMN = 8.617385 D-14 )
31967 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31968 PARAMETER ( GFOHB3 = 1.16639 D-05 )
31969 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31970 PARAMETER ( SIN2TW = 0.2319 D+00 )
31971 PARAMETER ( GEVMEV = 1.0 D+03 )
31972 PARAMETER ( EMVGEV = 1.0 D-03 )
31973 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
31974 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31975 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31976 LOGICAL LGBIAS, LGBANA
31977 COMMON /FKGLOB/ LGBIAS, LGBANA
31978 C INCLUDE '(DIMPAR)'
31980 PARAMETER ( MXXRGN = 5000 )
31981 PARAMETER ( MXXMDF = 82 )
31982 PARAMETER ( MXXMDE = 54 )
31983 PARAMETER ( MFSTCK = 1000 )
31984 PARAMETER ( MESTCK = 100 )
31985 PARAMETER ( NELEMX = 80 )
31986 PARAMETER ( MPDPDX = 8 )
31987 PARAMETER ( ICOMAX = 180 )
31988 PARAMETER ( NSTBIS = 304 )
31989 PARAMETER ( IDMAXP = 220 )
31990 PARAMETER ( IDMXDC = 640 )
31991 PARAMETER ( MKBMX1 = 1 )
31992 PARAMETER ( MKBMX2 = 1 )
31993 C INCLUDE '(IOUNIT)'
31995 PARAMETER ( LUNIN = 5 )
31996 PARAMETER ( LUNOUT = 6 )
31997 **sr 19.5. set error output-unit from 15 to 6
31998 PARAMETER ( LUNERR = 6 )
31999 PARAMETER ( LUNBER = 14 )
32000 PARAMETER ( LUNECH = 8 )
32001 PARAMETER ( LUNFLU = 13 )
32002 PARAMETER ( LUNGEO = 16 )
32003 PARAMETER ( LUNPMF = 12 )
32004 PARAMETER ( LUNRAN = 2 )
32005 PARAMETER ( LUNXSC = 9 )
32006 PARAMETER ( LUNDET = 17 )
32007 PARAMETER ( LUNRAY = 10 )
32008 PARAMETER ( LUNRDB = 1 )
32009 PARAMETER ( LUNPGO = 7 )
32010 PARAMETER ( LUNPGS = 4 )
32011 PARAMETER ( LUNSCR = 3 )
32013 *----------------------------------------------------------------------*
32015 * Block Data for the EVAPoration routines: *
32017 * Created on 20 may 1990 by Alfredo Ferrari & Paola Sala *
32020 * Modified from the original version of J.M.Zazula *
32021 * and, for cookcm, from a LAHET block data kindly provided by *
32024 * Last change on 20-feb-95 by Alfredo Ferrari *
32027 *----------------------------------------------------------------------*
32029 * (original name: COOKCM)
32030 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
32031 LOGICAL LDEFOZ, LDEFON
32032 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
32033 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
32034 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
32035 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
32036 * (original name: EVA0)
32037 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
32038 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
32039 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32040 * T (4,7), RMASS (297), ALPH (297), BET (297),
32041 * APRIME (250), IA (6), IZ (6)
32042 * (original name: HETTP)
32043 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
32044 * (original name: HETC7)
32045 COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32046 * (original name: INPFLG)
32047 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32049 DATA B0 / 8.D+00 /, Y0 / 1.5D+00 /
32050 DATA IANG / 1 /, IFISS / 1 /, IB0 / 2 /, IGEOM / 0 /
32051 DATA ISTRAG /0/, KEYDK /0/
32052 DATA NBERTP /LUNBER/
32053 DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32056 DATA ( PZCOOK(I),I = 1, IZCOOK ) /
32057 & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32058 & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32059 & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32060 & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32061 & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32062 & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32063 & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32064 & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32065 & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32066 & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32067 &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32068 & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32069 & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32070 & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32071 & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32072 &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32073 & 0.000D+00, 7.700D-01/
32074 DATA ( PNCOOK(I),I = 1, 90 ) /
32075 & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32076 & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32077 & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32078 & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32079 & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32080 & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32081 &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32082 & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32083 & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32084 & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32085 &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32086 &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32087 &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32088 &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32089 &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32090 DATA ( PNCOOK(I),I = 91, INCOOK ) /
32091 &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32092 &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32093 & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32094 & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32095 &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32096 & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32097 & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32098 & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32099 & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32100 & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32101 DATA ( SZCOOK(I),I = 1, 98) /
32102 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32103 & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32104 &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32105 &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32106 &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32107 &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32108 &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32109 &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32110 &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32111 &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32112 &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32113 &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32114 &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32115 &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32116 &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32117 &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32118 &-7.200D+00,-7.740D+00/
32119 DATA ( SNCOOK(I),I = 1, 90 ) /
32120 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32121 & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32122 & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32123 & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32124 & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32125 & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32126 & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32127 & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32128 & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32129 & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32130 & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32131 & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32132 & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32133 & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32134 & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32135 DATA ( SNCOOK(I),I = 91, INCOOK ) /
32136 & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32137 & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32138 & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32139 & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32140 & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32141 & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32142 &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32143 & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32144 & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32145 & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32146 DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32147 DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32148 *=== End of Block Data Bdevap =========================================*
32151 *$ CREATE DT_BDNOPT.FOR
32154 *=== bdnopt ===========================================================*
32156 BLOCK DATA DT_BDNOPT
32158 C INCLUDE '(DBLPRC)'
32160 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32162 * (original name: GLOBAL)
32163 PARAMETER ( KALGNM = 2 )
32164 PARAMETER ( ANGLGB = 5.0D-16 )
32165 PARAMETER ( ANGLSQ = 2.5D-31 )
32166 PARAMETER ( AXCSSV = 0.2D+16 )
32167 PARAMETER ( ANDRFL = 1.0D-38 )
32168 PARAMETER ( AVRFLW = 1.0D+38 )
32169 PARAMETER ( AINFNT = 1.0D+30 )
32170 PARAMETER ( AZRZRZ = 1.0D-30 )
32171 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32172 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32173 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32174 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32175 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32176 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32177 PARAMETER ( CSNNRM = 2.0D-15 )
32178 PARAMETER ( DMXTRN = 1.0D+08 )
32179 PARAMETER ( ZERZER = 0.D+00 )
32180 PARAMETER ( ONEONE = 1.D+00 )
32181 PARAMETER ( TWOTWO = 2.D+00 )
32182 PARAMETER ( THRTHR = 3.D+00 )
32183 PARAMETER ( FOUFOU = 4.D+00 )
32184 PARAMETER ( FIVFIV = 5.D+00 )
32185 PARAMETER ( SIXSIX = 6.D+00 )
32186 PARAMETER ( SEVSEV = 7.D+00 )
32187 PARAMETER ( EIGEIG = 8.D+00 )
32188 PARAMETER ( ANINEN = 9.D+00 )
32189 PARAMETER ( TENTEN = 10.D+00 )
32190 PARAMETER ( HLFHLF = 0.5D+00 )
32191 PARAMETER ( ONETHI = ONEONE / THRTHR )
32192 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32193 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32194 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32195 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32196 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32197 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32198 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32199 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32200 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32201 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32202 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32203 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32204 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32205 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32206 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32207 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32208 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32209 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32210 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32211 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32212 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32213 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32214 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32215 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32216 PARAMETER ( BOLTZM = 1.380658 D-23 )
32217 PARAMETER ( AMELGR = 9.1093897 D-28 )
32218 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32219 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32220 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32221 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32222 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32223 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32224 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32225 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32226 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32227 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32228 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32229 PARAMETER ( PLABRC = 0.197327053 D+00 )
32230 PARAMETER ( AMELCT = 0.51099906 D-03 )
32231 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32232 PARAMETER ( AMMUON = 0.105658389 D+00 )
32233 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32234 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32235 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32236 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32238 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32239 PARAMETER ( BLTZMN = 8.617385 D-14 )
32240 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32241 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32242 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32243 PARAMETER ( SIN2TW = 0.2319 D+00 )
32244 PARAMETER ( GEVMEV = 1.0 D+03 )
32245 PARAMETER ( EMVGEV = 1.0 D-03 )
32246 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32247 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32248 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32249 LOGICAL LGBIAS, LGBANA
32250 COMMON /FKGLOB/ LGBIAS, LGBANA
32251 C INCLUDE '(DIMPAR)'
32253 PARAMETER ( MXXRGN = 5000 )
32254 PARAMETER ( MXXMDF = 82 )
32255 PARAMETER ( MXXMDE = 54 )
32256 PARAMETER ( MFSTCK = 1000 )
32257 PARAMETER ( MESTCK = 100 )
32258 PARAMETER ( NELEMX = 80 )
32259 PARAMETER ( MPDPDX = 8 )
32260 PARAMETER ( ICOMAX = 180 )
32261 PARAMETER ( NSTBIS = 304 )
32262 PARAMETER ( IDMAXP = 220 )
32263 PARAMETER ( IDMXDC = 640 )
32264 PARAMETER ( MKBMX1 = 1 )
32265 PARAMETER ( MKBMX2 = 1 )
32266 C INCLUDE '(IOUNIT)'
32268 PARAMETER ( LUNIN = 5 )
32269 PARAMETER ( LUNOUT = 6 )
32270 **sr 19.5. set error output-unit from 15 to 6
32271 PARAMETER ( LUNERR = 6 )
32272 PARAMETER ( LUNBER = 14 )
32273 PARAMETER ( LUNECH = 8 )
32274 PARAMETER ( LUNFLU = 13 )
32275 PARAMETER ( LUNGEO = 16 )
32276 PARAMETER ( LUNPMF = 12 )
32277 PARAMETER ( LUNRAN = 2 )
32278 PARAMETER ( LUNXSC = 9 )
32279 PARAMETER ( LUNDET = 17 )
32280 PARAMETER ( LUNRAY = 10 )
32281 PARAMETER ( LUNRDB = 1 )
32282 PARAMETER ( LUNPGO = 7 )
32283 PARAMETER ( LUNPGS = 4 )
32284 PARAMETER ( LUNSCR = 3 )
32286 *----------------------------------------------------------------------*
32288 * Created on 20 september 1989 by Alfredo Ferrari - Infn Milan *
32290 * Last change on 20-apr-95 by Alfredo Ferrari *
32292 *----------------------------------------------------------------------*
32294 C INCLUDE '(BLNKCM)'
32296 **sr 17.5. commented since not used here
32297 C PARAMETER ( NBLNMX = 1100000 )
32298 C DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32299 C & BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32300 C & COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32303 C COMMON NSTOR ( KALGNM*NBLNMX )
32305 **sr 18.5. commented since not used for evap.
32306 C COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32307 C & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32308 C & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32309 C & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32310 C & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32311 C & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32312 C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32313 C & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32314 C & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32315 C & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32319 C EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32320 C EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32321 C EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32322 C EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32323 C EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32324 C EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32325 C EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32326 C INCLUDE '(BLNTMP)'
32328 **sr 18.5. commented since not used for evap.
32329 C COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32330 C & KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32331 C & KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32334 C INCLUDE '(CMMDNR)'
32336 **sr 18.5. commented since not used for evap.
32338 C COMMON / CMMDNR / DDNEAR, LFLDNR
32340 C INCLUDE '(CTITLE)'
32342 **sr 18.5. commented since not used for evap.
32343 C CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32344 C COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32345 C COMMON / CEXPCK / ITEXPI, ITEXMX
32347 C INCLUDE '(DETECT)'
32349 **sr 18.5. commented since not used for evap.
32350 C PARAMETER (NRGNMX = 10)
32351 C PARAMETER (NDTCMX = 10)
32352 C PARAMETER (NSCRMX = 10)
32353 C PARAMETER (NDTBIN = 1024)
32354 C CHARACTER*10 TITDET,TITSCO
32356 C COMMON /DETCT/ EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32357 C & KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32358 C & NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32360 C COMMON /DETCH/ TITDET(NDTCMX), TITSCO(NSCRMX)
32362 C INCLUDE '(DETLOC)'
32364 **sr 18.5. commented since not used for evap.
32365 C PARAMETER (NDTCM2 = 10)
32366 C COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32367 C & ICOINC(NDTCM2), NCLAS
32369 C INCLUDE '(EMGTRN)'
32371 **sr 18.5. commented since not used for evap.
32373 C COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32375 C INCLUDE '(EMSHO)'
32377 **sr 18.5. commented since not used for evap.
32378 C LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32379 C COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32380 C & EMFHLO, EMFELO, LIMPRE, LEXPTE
32382 C INCLUDE '(EPISOR)'
32384 **sr 18.5. commented since not used for evap.
32386 C COMMON/EPISOR/TKESUM,LUSSRC
32388 * (original name: FHEAVY,FHEAVC)
32389 PARAMETER ( MXHEAV = 100 )
32391 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32392 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32393 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32394 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
32395 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
32396 & IBHEAV ( 12 ) , NPHEAV
32397 COMMON /FKFHVC/ ANHEAV ( 12 )
32398 * (original name: FINUC)
32399 PARAMETER (MXP=999)
32400 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
32401 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32402 & TKI (MXP), PLR (MXP), WEI (MXP),
32403 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32405 C INCLUDE '(GENTHR)'
32407 **sr 18.5. commented since not used for evap.
32408 C COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32409 C & PTHDFF (NALLWP), IJNUCR (NALLWP)
32411 C INCLUDE '(LOWNEU)'
32413 **sr 18.5. commented since not used for evap.
32414 C PARAMETER ( MXGTHN = 15 )
32415 C PARAMETER ( MXGLWN = 200 )
32416 C PARAMETER ( MXSHPP = 5 )
32417 C LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32418 C CHARACTER*10 TITLOW
32419 C COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32420 C & SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32421 C & VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32422 C & STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32423 C & TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32424 C & IGTMRT (MXXMDF), NEUMED (MXXMDF),
32425 C & ID1MED (MXXMDF), ID2MED (MXXMDF),
32426 C & ID3MED (MXXMDF), MGTMED (MXXMDF),
32427 C & LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32428 C & NMTG , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32429 C & LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32430 C & I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32431 C & IWWLWT, IPXBGN, NPXSEC
32432 C COMMON / CHLWNT / TITLOW (MXXMDF)
32434 C INCLUDE '(LTCLCM)'
32436 **sr 18.5. commented since not used for evap.
32437 C COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32439 C INCLUDE '(MULBOU)'
32441 **sr 18.5. commented since not used for evap.
32442 C LOGICAL LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32443 C COMMON / MULBOU / UOLD , VOLD , WOLD , UMAG , VMAG , WMAG ,
32444 C & UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32445 C & TSENSE, DDSENS, DSMALL, NSSENS, LLDA , LAGAIN,
32446 C & LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32448 C INCLUDE '(MULHD)'
32450 **sr 18.5. commented since not used for evap.
32451 C PARAMETER ( MXXPT1 = 1 )
32452 C PARAMETER ( TIMESS = 2.00D+00 )
32453 C PARAMETER ( TMSRLX = 1.50D+00 )
32454 C PARAMETER ( EPSINS = 0.15D+00 )
32455 C PARAMETER ( EPSRLX = 0.50D+00 )
32456 C PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32457 C PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32458 C PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32459 C PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32460 C PARAMETER ( R0NCMS = 1.20 D+00 )
32461 C LOGICAL LTOPT, LSRCRH, LNSCRH
32462 C COMMON / MULHD / BLCC ( MXXMDF ), BLCCRA ( MXXMDF ),
32463 C & XCC ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32464 C & ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU ( MXXMDF ),
32465 C & ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0 ( MXXMDF ),
32466 C & XR0 ( MXXMDF ), ECUTM ( MXXMDF, 39, 2 ),
32467 C & ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32468 C & AE1O3 ( MXXMDF ), PARNSR ( MXXMDF ),
32469 C & HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32470 C & HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32471 C & LTOPT ( MXXMDF ), NFSCAT
32473 * (original name: PAREVT)
32474 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32475 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32476 PARAMETER ( NALLWP = 39 )
32477 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32478 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32479 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32480 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32481 * (original name: RESNUC)
32482 LOGICAL LRNFSS, LFRAGM
32483 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32484 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32485 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
32486 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
32487 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32488 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32489 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32490 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32492 C INCLUDE '(SCOHLP)'
32494 **sr 18.5. commented since not used for evap.
32496 C COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32498 C INCLUDE '(TRACKR)'
32500 **sr 18.5. commented since not used for evap.
32501 C PARAMETER ( MXTRCK = 2500 )
32503 C COMMON / TRACKR / XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32504 C & ZTRACK ( 0:MXTRCK ), TTRACK ( MXTRCK ),
32505 C & DTRACK ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32506 C & ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32507 C & NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32508 C & LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32510 C INCLUDE '(USRBDX)'
32512 **sr 18.5. commented since not used for evap.
32513 C PARAMETER ( MXUSBX = 600 )
32514 C LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32515 C CHARACTER*10 TITUSX
32516 C COMMON /USRBX/ EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32517 C & ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32518 C & AUSBDX(MXUSBX),
32519 C & NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32520 C & NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32521 C & KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32522 C & LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32524 C COMMON /USXCH/ TITUSX(MXUSBX)
32526 C INCLUDE '(USRBIN)'
32528 **sr 18.5. commented since not used for evap.
32529 C PARAMETER ( MXUSBN = 100 )
32530 C LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32531 C CHARACTER*10 TITUSB
32532 C COMMON /USRBN/ XLOW (MXUSBN), XHIGH (MXUSBN), YLOW (MXUSBN),
32533 C & YHIGH (MXUSBN), ZLOW (MXUSBN), ZHIGH (MXUSBN),
32534 C & DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32535 C & TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32536 C & NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32537 C & ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32538 C & IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32539 C & LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32540 C COMMON /USRCH/ TITUSB(MXUSBN)
32542 C INCLUDE '(USRSNC)'
32544 **sr 18.5. commented since not used for evap.
32545 C PARAMETER ( MXRSNC = 400 )
32546 C PARAMETER ( NMZMIN = -5 )
32548 C CHARACTER*10 TIURSN
32549 C COMMON /USRSNC/ VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32550 C & NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32551 C & IPURSN(MXRSNC), NURSNC, LURSNC
32552 C COMMON /USRSCH/ TIURSN(MXRSNC)
32553 C INCLUDE '(USRTRC)'
32555 **sr 18.5. commented since not used for evap.
32556 C PARAMETER ( MXUSTC = 400 )
32557 C LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32558 C CHARACTER*10 TITUTC
32559 C COMMON /USRTC/ ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32560 C & VUSRTC(MXUSTC),
32561 C & IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32562 C & NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32563 C & KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32564 C & LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32566 C COMMON /USTCH/ TITUTC(MXUSTC)
32568 C INCLUDE '(USRYLD)'
32570 **sr 18.5. commented since not used for evap.
32571 C PARAMETER ( MXUSYL = 500 )
32572 C LOGICAL LUSRYL, LLNUYL, LSCUYL
32573 C CHARACTER*10 TITUYL
32574 C COMMON /USRYL/ EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32575 C & USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32576 C & AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32577 C & ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32578 C & VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32579 C & NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32580 C & IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32581 C & KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32582 C & IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32583 C & NUSRYL, LUSRYL, LSCUYL
32584 C COMMON /USYCH/ TITUYL(MXUSYL)
32586 C INCLUDE '(WWINDW)'
32588 **sr 18.5. commented since not used for evap.
32589 C PARAMETER ( MXWWSP = 3 )
32590 C PARAMETER ( WWSPMX = 50.D+00 )
32591 C LOGICAL LWWNDW, LWWPRM
32592 C COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32593 C & WWEXWD (NALLWP), EXTWWN (NALLWP),
32594 C & IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32598 * *** If blank common dimension has to be superseded substitute in the
32599 * *** following two lines the new dimension in real*8 units to Nblnmx
32600 **sr 18.5. commented since not used for evap.
32601 C PARAMETER (MXDUMM = KALGNM * NBLNMX)
32602 C DATA KTMBGN / NBLNMX /
32603 C DATA MBLNMX / MXDUMM /
32604 C DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32605 C & KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32606 C & KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32607 C & KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32608 C & KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32609 C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32610 C & KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32611 C & KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32612 C & KBRLST / 57*0 /
32615 **sr 18.5. commented since not used for evap.
32616 C DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32617 C & KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32618 C & KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32621 **sr 18.5. commented since not used for evap.
32622 C DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32625 **sr 18.5. commented since not used for evap.
32626 C DATA RUNTIT (1:40) / '****************************************' /
32627 C DATA RUNTIT(41:80) / '****************************************' /
32628 C DATA ITEXPI, ITEXMX / 100000000, 150 /
32630 **sr 18.5. commented since not used for evap.
32631 C PARAMETER (NNN1 = NRGNMX*NDTCMX)
32632 C PARAMETER (NNN2 = NSCRMX*NDTCMX)
32633 C DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32634 C DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32635 C DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32636 C DATA TITDET/NDTCMX*' '/, TITSCO/NSCRMX*' '/
32639 **sr 18.5. commented since not used for evap.
32640 C DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32644 **sr 18.5. commented since not used for evap.
32645 C DATA LMCSMG / .FALSE. /
32648 **sr 18.5. commented since not used for evap.
32649 C DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32652 **sr 18.5. commented since not used for evap.
32653 C DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32656 DATA AMHEAV / 12 * 0.D+00 /
32657 DATA ANHEAV / 'NEUTRON ', 'PROTON ', 'DEUTERON', '3-H ',
32658 & '3-He ', '4-He ', 'H-FRAG-1', 'H-FRAG-2',
32659 & 'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32660 DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32661 & IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32665 DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32666 & TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32670 * DATA PEANCT, PEAPIT / 2*1.D+00 /
32671 * DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32673 * DATA PTHDFF / 39*5.D+00 /
32676 **sr 18.5. commented since not used for evap.
32677 C DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32678 C DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32679 C & 3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32681 C DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32682 C & 3.5D+00, 13*5.D+00 /
32683 C DATA PLDNCT / 0.26D+00 /
32684 C DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32687 **sr 18.5. commented since not used for evap.
32688 C DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32689 C DATA IWWLWB, IWWLWT / 2 * 100000000 /
32690 C DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32691 C DATA IGRTHN / 1 /
32692 C DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32693 C & LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32696 **sr 18.5. commented since not used for evap.
32697 C DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32700 **sr 18.5. commented since not used for evap.
32701 C DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32702 C & / 7 * .FALSE. /
32703 C DATA TSENSE / AINFNT /, NSSENS / -1 /
32704 C DATA DSMALL / ANGLGB /
32707 **sr 18.5. commented since not used for evap.
32708 C DATA LTOPT / MXXMDF * .FALSE. /, NFSCAT / 0 /
32709 C DATA ESTEPF / MXXMDF * 0.1D+00 /
32710 C DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32711 C DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32714 DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32715 & RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32716 DATA LDIFFR / .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32717 & .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32718 & 4 * .FALSE., 9 * .TRUE./
32720 * default value for LEVPRT changed (reset sr 25.7.97)
32721 * default value for LHEAVY changed 25.7.97
32722 C DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32723 C & LHEAVY / .FALSE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32724 C & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32725 C & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32726 DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32727 & LHEAVY / .TRUE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32728 & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32729 & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32732 * default value for ILVMOD changed
32733 C DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32734 DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32738 DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32740 DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32741 & IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32743 DATA LRNFSS / .FALSE. /
32746 **sr 18.5. commented since not used for evap.
32747 C DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32750 **sr 18.5. commented since not used for evap.
32751 C DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32752 C & CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32755 **sr 18.5. commented since not used for evap.
32756 C DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32759 **sr 18.5. commented since not used for evap.
32760 C DATA LUSBDX /.FALSE./, NUSRBX /0/
32763 **sr 18.5. commented since not used for evap.
32764 C DATA LURSNC /.FALSE./, NURSNC /0/
32767 **sr 18.5. commented since not used for evap.
32768 C DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32769 C DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32772 **sr 18.5. commented since not used for evap.
32773 C DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32774 C & IJUSYL /0/, JTUSYL /0/
32775 C DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32778 **sr 18.5. commented since not used for evap.
32779 C DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32780 C DATA LWWPRM / .TRUE. /
32782 *= end*block.bdnopt *
32785 *$ CREATE DT_BDPREE.FOR
32788 *=== bdpree ===========================================================*
32790 BLOCK DATA DT_BDPREE
32792 C INCLUDE '(DBLPRC)'
32794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32796 * (original name: GLOBAL)
32797 PARAMETER ( KALGNM = 2 )
32798 PARAMETER ( ANGLGB = 5.0D-16 )
32799 PARAMETER ( ANGLSQ = 2.5D-31 )
32800 PARAMETER ( AXCSSV = 0.2D+16 )
32801 PARAMETER ( ANDRFL = 1.0D-38 )
32802 PARAMETER ( AVRFLW = 1.0D+38 )
32803 PARAMETER ( AINFNT = 1.0D+30 )
32804 PARAMETER ( AZRZRZ = 1.0D-30 )
32805 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32806 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32807 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32808 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32809 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32810 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32811 PARAMETER ( CSNNRM = 2.0D-15 )
32812 PARAMETER ( DMXTRN = 1.0D+08 )
32813 PARAMETER ( ZERZER = 0.D+00 )
32814 PARAMETER ( ONEONE = 1.D+00 )
32815 PARAMETER ( TWOTWO = 2.D+00 )
32816 PARAMETER ( THRTHR = 3.D+00 )
32817 PARAMETER ( FOUFOU = 4.D+00 )
32818 PARAMETER ( FIVFIV = 5.D+00 )
32819 PARAMETER ( SIXSIX = 6.D+00 )
32820 PARAMETER ( SEVSEV = 7.D+00 )
32821 PARAMETER ( EIGEIG = 8.D+00 )
32822 PARAMETER ( ANINEN = 9.D+00 )
32823 PARAMETER ( TENTEN = 10.D+00 )
32824 PARAMETER ( HLFHLF = 0.5D+00 )
32825 PARAMETER ( ONETHI = ONEONE / THRTHR )
32826 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32827 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32828 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32829 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32830 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32831 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32832 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32833 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32834 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32835 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32836 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32837 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32838 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32839 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32840 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32841 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32842 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32843 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32844 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32845 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32846 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32847 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32848 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32849 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32850 PARAMETER ( BOLTZM = 1.380658 D-23 )
32851 PARAMETER ( AMELGR = 9.1093897 D-28 )
32852 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32853 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32854 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32855 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32856 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32857 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32858 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32859 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32860 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32861 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32862 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32863 PARAMETER ( PLABRC = 0.197327053 D+00 )
32864 PARAMETER ( AMELCT = 0.51099906 D-03 )
32865 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32866 PARAMETER ( AMMUON = 0.105658389 D+00 )
32867 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32868 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32869 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32870 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32872 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32873 PARAMETER ( BLTZMN = 8.617385 D-14 )
32874 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32875 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32876 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32877 PARAMETER ( SIN2TW = 0.2319 D+00 )
32878 PARAMETER ( GEVMEV = 1.0 D+03 )
32879 PARAMETER ( EMVGEV = 1.0 D-03 )
32880 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32881 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32882 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32883 LOGICAL LGBIAS, LGBANA
32884 COMMON /FKGLOB/ LGBIAS, LGBANA
32885 C INCLUDE '(DIMPAR)'
32887 PARAMETER ( MXXRGN = 5000 )
32888 PARAMETER ( MXXMDF = 82 )
32889 PARAMETER ( MXXMDE = 54 )
32890 PARAMETER ( MFSTCK = 1000 )
32891 PARAMETER ( MESTCK = 100 )
32892 PARAMETER ( NALLWP = 39 )
32893 PARAMETER ( NELEMX = 80 )
32894 PARAMETER ( MPDPDX = 8 )
32895 PARAMETER ( ICOMAX = 180 )
32896 PARAMETER ( NSTBIS = 304 )
32897 PARAMETER ( IDMAXP = 220 )
32898 PARAMETER ( IDMXDC = 640 )
32899 PARAMETER ( MKBMX1 = 1 )
32900 PARAMETER ( MKBMX2 = 1 )
32901 C INCLUDE '(IOUNIT)'
32903 PARAMETER ( LUNIN = 5 )
32904 PARAMETER ( LUNOUT = 6 )
32905 **sr 19.5. set error output-unit from 15 to 6
32906 PARAMETER ( LUNERR = 6 )
32907 PARAMETER ( LUNBER = 14 )
32908 PARAMETER ( LUNECH = 8 )
32909 PARAMETER ( LUNFLU = 13 )
32910 PARAMETER ( LUNGEO = 16 )
32911 PARAMETER ( LUNPMF = 12 )
32912 PARAMETER ( LUNRAN = 2 )
32913 PARAMETER ( LUNXSC = 9 )
32914 PARAMETER ( LUNDET = 17 )
32915 PARAMETER ( LUNRAY = 10 )
32916 PARAMETER ( LUNRDB = 1 )
32917 PARAMETER ( LUNPGO = 7 )
32918 PARAMETER ( LUNPGS = 4 )
32919 PARAMETER ( LUNSCR = 3 )
32921 *----------------------------------------------------------------------*
32923 * Created on 16 september 1991 by Alfredo Ferrari & Paola Sala *
32926 * Last change on 03-feb-94 by Alfredo Ferrari *
32929 *----------------------------------------------------------------------*
32931 * (original name: CMPISG,CHPISG)
32932 PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32933 PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32934 PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32935 PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32936 PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32937 PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32938 PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32939 PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32940 PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32941 PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32942 PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32943 PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32944 PARAMETER ( PIRSMX = 1.2D+00 )
32945 PARAMETER ( NPIREA = 10 )
32946 PARAMETER ( NPIRTA = 68 )
32947 PARAMETER ( NPIRLN = 21 )
32948 PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32949 PARAMETER ( NPISIS = NPIRLN + 20 )
32950 PARAMETER ( NPISEX = NPIRLN + 21 )
32951 PARAMETER ( NPIIMN = 14 )
32952 PARAMETER ( NPIIRC = 6 )
32953 PARAMETER ( DELWLL = 0.035D+00 )
32956 COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32957 & RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32958 & ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32959 & CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32960 & SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32961 & SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5) ,
32962 & SGPICU (0:20,NPIRTA,NPIREA) , SGRTRS (NPIREA),
32963 & SGPIDF (0:20,NPIRTA,NPIREA) , BRREIN (NPIREA),
32964 & SGPIIS (NPIRTA,NPIREA) , BRREOU (NPIREA),
32965 & BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32966 & SGABSR (2,2,4) , PRRSDL,
32967 & IPIREA (2,2,3:5) , IPIINE (2,3:5) , NPIRVR ,
32968 & KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32969 & JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32970 COMMON /FKCHPI/ CHPIRE (NPIREA)
32971 DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32972 EQUIVALENCE ( SG2BRS (1,1), SGABSR (1,1,1) )
32973 EQUIVALENCE ( SGABSW (1,1), SGABSR (1,1,2) )
32974 EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32975 * (original name: FRBKCM)
32976 PARAMETER ( MXFFBK = 6 )
32977 PARAMETER ( MXZFBK = 9 )
32978 PARAMETER ( MXNFBK = 10 )
32979 PARAMETER ( MXAFBK = 16 )
32980 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32981 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32982 PARAMETER ( NXAFBK = MXAFBK + 1 )
32983 PARAMETER ( MXPSST = 300 )
32984 PARAMETER ( MXPSFB = 41000 )
32985 LOGICAL LFRMBK, LNCMSS
32986 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
32987 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
32988 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
32989 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
32990 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
32991 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
32992 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
32993 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
32994 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
32995 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
32996 PARAMETER ( PI = PIPIPI )
32997 PARAMETER ( PISQ = PIPISQ )
32998 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
32999 PARAMETER ( RZNUCL = 1.12 D+00 )
33000 PARAMETER ( RMSPRO = 0.8 D+00 )
33001 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
33002 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
33004 PARAMETER ( RLLE04 = RZNUCL )
33005 PARAMETER ( RLLE16 = RZNUCL )
33006 PARAMETER ( RLGT16 = RZNUCL )
33007 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
33008 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
33009 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
33010 PARAMETER ( SKLE04 = 1.4D+00 )
33011 PARAMETER ( SKLE16 = 1.9D+00 )
33012 PARAMETER ( SKGT16 = 2.4D+00 )
33013 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
33014 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
33015 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
33016 PARAMETER ( ALPHA0 = 0.1D+00 )
33017 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
33018 PARAMETER ( GAMSK0 = 0.9D+00 )
33019 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
33020 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
33021 PARAMETER ( POTBA0 = 1.D+00 )
33022 PARAMETER ( PNFRAT = 1.533D+00 )
33023 PARAMETER ( RADPIM = 0.035D+00 )
33024 PARAMETER ( RDPMHL = 14.D+00 )
33025 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
33026 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
33027 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
33028 PARAMETER ( AP0PFS = 0.5D+00 )
33029 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
33030 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
33031 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
33032 PARAMETER ( MXSCIN = 50 )
33033 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
33034 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
33035 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
33036 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
33037 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
33038 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
33040 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33041 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33042 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33043 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33044 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33045 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33046 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33047 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33048 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33049 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33050 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33051 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33052 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33053 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33054 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33055 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33056 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33057 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33058 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33059 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33060 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33061 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33062 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33063 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33064 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33065 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
33066 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33067 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33068 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33069 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33070 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33071 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33072 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33073 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33074 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33075 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33076 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33077 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33078 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33079 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33081 DIMENSION AWSTAB (2:260), SIGMAB (3)
33082 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33083 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33084 EQUIVALENCE ( RHOIPP, RHONCP (1) )
33085 EQUIVALENCE ( RHOINP, RHONCP (2) )
33086 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33087 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33088 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33089 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33090 EQUIVALENCE ( RHOIPT, RHONCT (1) )
33091 EQUIVALENCE ( RHOINT, RHONCT (2) )
33092 EQUIVALENCE ( OMALHL, SK3PAR )
33093 EQUIVALENCE ( ALPHAL, HABPAR )
33094 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33095 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33096 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33097 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33098 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33099 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33100 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33101 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33102 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33103 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33104 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33105 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33106 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33107 * (original name: NUCLEV)
33108 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33109 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33110 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33111 & CUMRAD (0:160,2), RUSNUC (2),
33112 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33113 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33114 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33115 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33116 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33117 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33118 & LFLVSL, LRLVSL, LEQSBL
33119 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33120 & MGSSPR (19) , MGSSNE (25)
33121 EQUIVALENCE ( RUSNUC (1), RUSPRO )
33122 EQUIVALENCE ( RUSNUC (2), RUSNEU )
33123 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33124 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33125 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33126 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33127 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33128 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33129 EQUIVALENCE ( NTANUC (1), NTAPRO )
33130 EQUIVALENCE ( NTANUC (2), NTANEU )
33131 EQUIVALENCE ( NAVNUC (1), NAVPRO )
33132 EQUIVALENCE ( NAVNUC (2), NAVNEU )
33133 EQUIVALENCE ( NLSNUC (1), NLSPRO )
33134 EQUIVALENCE ( NLSNUC (2), NLSNEU )
33135 EQUIVALENCE ( NCONUC (1), NCOPRO )
33136 EQUIVALENCE ( NCONUC (2), NCONEU )
33137 EQUIVALENCE ( NSKNUC (1), NSKPRO )
33138 EQUIVALENCE ( NSKNUC (2), NSKNEU )
33139 EQUIVALENCE ( NHANUC (1), NHAPRO )
33140 EQUIVALENCE ( NHANUC (2), NHANEU )
33141 EQUIVALENCE ( NUSNUC (1), NUSPRO )
33142 EQUIVALENCE ( NUSNUC (2), NUSNEU )
33143 EQUIVALENCE ( NACNUC (1), NACPRO )
33144 EQUIVALENCE ( NACNUC (2), NACNEU )
33145 EQUIVALENCE ( JMXNUC (1), JMXPRO )
33146 EQUIVALENCE ( JMXNUC (2), JMXNEU )
33147 EQUIVALENCE ( MAGNUC (1), MAGPRO )
33148 EQUIVALENCE ( MAGNUC (2), MAGNEU )
33149 * (original name: PARNUC)
33150 PARAMETER ( PIGRK = PIPIPI )
33151 PARAMETER ( ALEVEL = 8.D-03 )
33152 PARAMETER ( RCNUCL = 1.12D+00 )
33153 PARAMETER ( R0SIG = 1.3D+00 )
33154 PARAMETER ( R0SIGK = 1.5D+00 )
33155 PARAMETER ( RCOULB = 1.5D+00 )
33156 PARAMETER ( COULBH = 0.88235D-03 )
33157 PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33158 PARAMETER ( TAUFO0 = 10.0D+00 )
33159 PARAMETER ( EKEEXP = 0.03D+00 )
33160 PARAMETER ( EKREXP = 0.05D+00 )
33161 PARAMETER ( EKEMNM = 0.01D+00 )
33162 PARAMETER ( NCPMX = 120 )
33163 COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33164 & ENNUC (NCPMX), PNUCL (NCPMX), EKFNUC (NCPMX),
33165 & XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33166 & PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33167 & RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33168 & CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33169 & TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33170 & KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33171 & INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33172 & IBNUCL, NPNUC , NNUCTS
33174 DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33175 DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33176 DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33177 DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33178 DATA LPREEQ / .FALSE. /
33180 DATA JSTOKP / 1, 8, 13, 14, 23 /
33181 DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33182 DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33183 & 'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33184 & 'PI0NPI0N','PI0NPI-P' /
33185 DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33186 & 13, 8, 13, 8, 23, 8, 23, 8 /
33187 DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33188 & 13, 8, 23, 1, 23, 8, 14, 1 /
33189 DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33190 DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33192 DATA LFRMBK / .FALSE. /
33193 DATA NBUFBK / 500 /
33194 DATA EXMXFB / 80.0 D+00 /
33195 DATA R0FRBK / 1.18 D+00 /
33196 DATA R0CFBK / 2.173D+00 /
33197 DATA C1CFBK / 6.103D-03 /
33198 DATA C2CFBK / 9.443D-03 /
33200 DATA TAUFOR / TAUFO0 /
33201 *=== End of Block Data Bdpree =========================================*
33204 *$ CREATE DT_XHOINI.FOR
33207 *====phoini============================================================*
33209 SUBROUTINE DT_XHOINI
33210 C SUBROUTINE DT_PHOINI
33212 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33214 PARAMETER ( LINP = 10 ,
33221 *$ CREATE DT_XVENTB.FOR
33224 *====eventb============================================================*
33226 SUBROUTINE DT_XVENTB(NCSY,IREJ)
33227 C SUBROUTINE DT_EVENTB(NCSY,IREJ)
33229 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33231 PARAMETER ( LINP = 10 ,
33236 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
33241 *$ CREATE DT_XVENT.FOR
33244 *===event==============================================================*
33246 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33247 C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33249 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33252 DIMENSION PP(4),PT(4)
33257 *$ CREATE DT_XOHISX.FOR
33260 *===pohisx=============================================================*
33262 SUBROUTINE DT_XOHISX(I,X)
33263 C SUBROUTINE POHISX(I,X)
33265 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33271 *$ CREATE PHO_LHIST.FOR
33274 *===poluhi=============================================================*
33276 SUBROUTINE PHO_LHIST(I,X)
33279 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33285 *$ CREATE PDFSET.FOR
33288 C**********************************************************************
33290 C dummy subroutines, remove to link PDFLIB
33292 C**********************************************************************
33293 SUBROUTINE PDFSET(PARAM,VALUE)
33294 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33295 DIMENSION PARAM(20),VALUE(20)
33299 *$ CREATE STRUCTM.FOR
33302 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33303 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33306 *$ CREATE STRUCTP.FOR
33309 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33310 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33313 *$ CREATE DT_DIQBRK.FOR
33316 *===diqbrk=============================================================*
33318 SUBROUTINE DT_XIQBRK
33319 C SUBROUTINE DT_DIQBRK
33321 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33324 STOP 'diquark-breaking not implemeted !'
33329 *$ CREATE DT_ELHAIN.FOR
33332 *===elhain=============================================================*
33334 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33336 ************************************************************************
33337 * Elastic hadron-hadron scattering. *
33338 * This is a revised version of the original. *
33339 * This version dated 03.04.98 is written by S. Roesler *
33340 ************************************************************************
33342 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33344 PARAMETER ( LINP = 10 ,
33347 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33350 PARAMETER (ENNTHR = 3.5D0)
33351 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33352 & BLOWB=0.05D0,BHIB=0.2D0,
33353 & BLOWM=0.1D0, BHIM=2.0D0)
33355 * particle properties (BAMJET index convention)
33357 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33358 & IICH(210),IIBAR(210),K1(210),K2(210)
33359 * final state from HADRIN interaction
33360 PARAMETER (MAXFIN=10)
33361 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33362 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33364 C DATA TSLOPE /10.0D0/
33370 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33371 EKIN = ELAB-AAM(IP)
33372 * kinematical quantities in cms of the hadrons
33375 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
33377 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33378 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33380 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33381 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33382 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33383 * TSAMCS treats pp and np only, therefore change pn into np and
33389 IF (IP.EQ.8) KPROJ = 1
33391 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33392 T = TWO*PCM**2*(CTCMS-ONE)
33394 * very crude treatment otherwise: sample t from exponential dist.
33396 * momentum transfer t
33397 TMAX = TWO*TWO*PCM**2
33398 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33399 IF (IIBAR(IP).NE.0) THEN
33400 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33402 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33404 FMAX = EXP(-TSLOPE*TMAX)-ONE
33406 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33407 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33410 * target hadron in Lab after scattering
33411 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33412 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33413 IF (PLRH(2).LE.TINY10) THEN
33414 C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33417 * projectile hadron in Lab after scattering
33418 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33419 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33420 * scattering angle of projectile in Lab
33421 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33422 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33423 CALL DT_DSFECF(SPLABP,CPLABP)
33424 * direction cosines of projectile in Lab
33425 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33426 & CXRH(1),CYRH(1),CZRH(1))
33427 * scattering angle of target in Lab
33428 PLLABT = PLAB-CTLABP*PLRH(1)
33429 CTLABT = PLLABT/PLRH(2)
33430 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33431 * direction cosines of target in Lab
33432 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33433 & CXRH(2),CYRH(2),CZRH(2))
33442 *$ CREATE DT_TSAMCS.FOR
33445 *===tsamcs=============================================================*
33447 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33449 ************************************************************************
33450 * Sampling of cos(theta) for nucleon-proton scattering according to *
33451 * hetkfa2/bertini parametrization. *
33452 * This is a revised version of the original (HJM 24/10/88) *
33453 * This version dated 28.10.95 is written by S. Roesler *
33454 ************************************************************************
33456 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33458 PARAMETER ( LINP = 10 ,
33461 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33464 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33465 DIMENSION PDCI(60),PDCH(55)
33467 DATA (DCLIN(I),I=1,80) /
33468 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
33469 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
33470 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
33471 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
33472 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
33473 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
33474 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
33475 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
33476 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
33477 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
33478 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
33479 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
33480 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
33481 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
33482 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
33483 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
33484 DATA (DCLIN(I),I=81,160) /
33485 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
33486 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
33487 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
33488 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
33489 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
33490 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
33491 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
33492 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
33493 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
33494 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
33495 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
33496 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
33497 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
33498 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
33499 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
33500 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
33501 DATA (DCLIN(I),I=161,195) /
33502 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
33503 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
33504 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
33505 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
33506 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
33507 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
33508 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
33511 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
33512 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
33513 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
33514 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
33515 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
33516 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
33517 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
33518 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
33519 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
33520 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
33521 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
33522 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
33525 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
33526 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
33527 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
33528 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
33529 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
33530 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
33531 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
33532 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
33533 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
33534 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
33535 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
33537 DATA (DCHN(I),I=1,90) /
33538 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
33539 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
33540 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
33541 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
33542 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
33543 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
33544 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
33545 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
33546 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
33547 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
33548 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
33549 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
33550 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
33551 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
33552 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
33553 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
33554 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
33555 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
33556 DATA (DCHN(I),I=91,143) /
33557 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
33558 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
33559 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
33560 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
33561 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
33562 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
33563 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
33564 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
33565 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
33566 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
33567 & 6.488D-02, 6.485D-02, 6.480D-02/
33570 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
33571 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
33572 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
33573 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
33574 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
33575 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
33576 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
33580 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
33581 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
33582 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
33583 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
33584 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
33585 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
33586 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33587 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
33588 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33589 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
33590 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33591 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
33594 IF (EKIN.GT.3.5D0) RETURN
33596 IF(KPROJ.EQ.8) GOTO 101
33597 IF(KPROJ.EQ.1) GOTO 102
33598 C* INVALID REACTION
33599 WRITE(LOUT,'(A,I5/A)')
33600 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33601 & ' COS(THETA) = 1D0 RETURNED'
33603 C-------------------------------- NP ELASTIC SCATTERING----------
33605 IF (EKIN.GT.0.740D0)GOTO 1000
33606 IF (EKIN.LT.0.300D0)THEN
33607 C EKIN .LT. 300 MEV
33610 C 300 MEV < EKIN < 740 MEV
33615 IE=INT(ABS(ENER/0.020D0))
33616 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33617 C FORWARD/BACKWARD DECISION
33619 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33620 IF (DT_RNDM(CST).LT.BWFW)THEN
33628 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33631 IF(RND.LT.COEF)THEN
33640 IF(VALUE2.GT.0.0)THEN
33641 CST=MAX(R1,R2,R3,R4)
33647 CST=-MAX(R1,R2,R3,R4,R5)
33651 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33660 C******** EKIN .GT. 0.74 GEV
33662 1000 ENER=EKIN - 0.66D0
33663 C IE=ABS(ENER/0.02)
33664 IE=INT(ENER/0.02D0)
33667 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33669 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33672 IF (RND.GE.BWFW)THEN
33674 IF (DCHNA(K).GT.EMEV) THEN
33675 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33676 UNIV=DT_RNDM(UNIVE)
33679 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33682 UNIV=DT_RNDM(UNIVE)
33684 GOTO(290,290,290,290,330,340,350,360) I
33693 IF (DCHNB(K).GT.EMEV) THEN
33694 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33695 UNIV=DT_RNDM(UNIVE)
33698 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33703 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33710 120 CST=1.0D-2*FLTI-1.0D0
33712 140 CST=2.0D-2*UNIV-0.98D0
33714 150 CST=4.0D-2*UNIV-0.96D0
33716 160 CST=6.0D-2*FLTI-1.16D0
33718 180 CST=8.0D-2*UNIV-0.80D0
33720 190 CST=1.0D-1*UNIV-0.72D0
33722 200 CST=1.2D-1*UNIV-0.62D0
33724 210 CST=2.0D-1*UNIV-0.50D0
33726 220 CST=3.0D-1*(UNIV-1.0D0)
33729 290 CST=1.0D0-2.5d-2*FLTI
33731 330 CST=0.85D0+0.5D-1*UNIV
33733 340 CST=0.70D0+1.5D-1*UNIV
33735 350 CST=0.50D0+2.0D-1*UNIV
33737 360 CST=0.50D0*UNIV
33741 C----------------------------------- PP ELASTIC SCATTERING -------
33746 IF (EKIN.LE.0.500D0) THEN
33748 CST=2.0D0*RND-1.0D0
33751 ELSEIF (EKIN.LT.1.0D0) THEN
33753 IF (PDCI(K).GT.EMEV) THEN
33754 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33755 UNIV=DT_RNDM(UNIVE)
33759 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33761 IF (UNIV.LT.SUM)THEN
33764 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33771 IF (PDCH(K).GT.EMEV) THEN
33772 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33773 UNIV=DT_RNDM(UNIVE)
33777 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33779 IF (UNIV.LT.SUM)THEN
33782 GOTO(50,55,60,60,65,65,65,65,70,70) I
33793 60 CST=0.3D0+0.1D0*FLTI
33795 65 CST=0.6D0+0.04D0*FLTI
33797 70 CST=0.78D0+0.02D0*FLTI
33800 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33805 *$ CREATE DT_DHADRI.FOR
33808 *===dhadri=============================================================*
33810 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33812 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33815 PARAMETER ( LINP = 10 ,
33819 C-----------------------------
33820 C*** INPUT VARIABLES LIST:
33821 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33822 C*** GEV/C LABORATORY MOMENTUM REGION
33823 C*** N - PROJECTILE HADRON INDEX
33824 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33825 C*** ELAB - LABORATORY ENERGY OF N (GEV)
33826 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33827 C*** ITTA - TARGET NUCLEON INDEX
33828 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33829 C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33830 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33831 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33832 C*** RESPECT., UNITS (GEV/C AND GEV)
33833 C----------------------------
33835 COMMON /HNGAMR/ REDU,AMO,AMM(15)
33836 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33837 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33838 & NRK(2,268),NURE(30,2)
33839 * particle properties (BAMJET index convention),
33840 * (dublicate of DTPART for HADRIN)
33841 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33842 & K1H(110),K2H(110)
33843 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33844 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33846 COMMON /HNDRUN/ RUNTES,EFTES
33847 * particle properties (BAMJET index convention)
33849 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33850 & IICH(210),IIBAR(210),K1(210),K2(210)
33851 * final state from HADRIN interaction
33852 PARAMETER (MAXFIN=10)
33853 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33854 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33856 DIMENSION ITPRF(110)
33859 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33861 IF (N.LE.0.OR.N.GE.111)N=1
33862 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33865 * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33867 *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33868 * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33871 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
33872 C IF(IPRI.GE.1) WRITE (6,1010) PLAB
33874 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33875 + ALLOWED REGION, PLAB=',1E15.5)
33878 UMODAT=N*1.11111D0+ITTA*2.19291D0
33879 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33886 IF (LOWP.GT.20) THEN
33887 C WRITE(LOUT,*) ' jump 1'
33891 IF (NNN.EQ.N) GO TO 50
33900 IF(ITTA.GT.1) IRE=NURE(N,2)
33902 C-----------------------------
33903 C*** IE,AMT,ECM,SI DETERMINATION
33904 C----------------------------
33905 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33908 C IF (AMH(1).NE.0.93828D0) IANTH=1
33909 IF (AMH(1).NE.0.9383D0) IANTH=1
33911 IF (IANTH.GE.0) SI=1.0D0
33914 C-----------------------------
33916 C IRE CHARACTERIZES THE REACTION
33917 C IE IS THE ENERGY INDEX
33918 C----------------------------
33919 IF (SI.LT.1.D-6) THEN
33920 C WRITE(LOUT,*) ' jump 2'
33923 IF (N.LE.NSTAB) GO TO 60
33924 RUNTES=RUNTES+1.0D0
33925 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33926 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33927 IF(IBARH(N).EQ.1) N=8
33928 IF(IBARH(N).EQ.-1) N=9
33931 **sr 19.2.97: loop for direct channel suppression
33932 C IF (IMACH.GT.10) THEN
33933 IF (IMACH.GT.1000) THEN
33935 C WRITE(LOUT,*) ' jump 3'
33941 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
33942 IF(ECMN.LE.AMN) ECMN=AMN
33943 PCMN=SQRT(ECMN**2-AMN2)
33946 IF (IANTH.GE.0) ECM=2.1D0
33948 C-----------------------------
33949 C*** RANDOM CHOICE OF REACTION CHANNEL
33950 C----------------------------
33955 C-----------------------------
33956 C*** PLACE REDUCED VERSION
33957 C----------------------------
33959 IDWK=IEII(IRE+1)-IIEI
33963 C-----------------------------
33964 C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33965 C----------------------------
33967 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33968 IF (HUMO.LT.ECM) ECM=HUMO
33970 C-----------------------------
33971 C*** INTERPOLATION PREPARATION
33972 C----------------------------
33978 C-----------------------------
33980 C----------------------------
33985 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33989 C-----------------------------
33990 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
33991 C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
33993 C----------------------------
33994 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
33995 WICO=WOK*1.23459876D0+WDK*1.735218469D0
33996 IF (WICO.EQ.WICOR) GO TO 70
33997 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
34000 C-----------------------------
34001 C*** INTERPOLATION IN CHANNEL WEIGHTS
34002 C----------------------------
34003 EKLIM=-THRESH(IIKI+IK)
34004 IELIM=IDT_IEFUND(EKLIM,IRE)
34005 DELIM=UMO(IELIM)+EKLIM
34007 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34008 IF (DELIM*DELIM-DETE*DETE) 90,90,80
34013 WKK=WOK-WDK*DEC/(DECC+1.D-9)
34015 C-----------------------------
34017 C----------------------------
34019 IF (VV.GT.WKK) GO TO 70
34021 C***IK IS THE REACTION CHANNEL
34022 C----------------------------
34034 IF (I1001.GT.50) GO TO 60
34036 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
34039 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34042 IF (IT2.GT.0) GO TO 120
34043 **sr 19.2.97: supress direct channel for pp-collisions
34044 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34046 IF (RR.LE.0.75D0) GOTO 60
34050 C-----------------------------
34051 C INCLUSION OF DIRECT RESONANCES
34052 C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
34053 C------------------------
34066 IF(WW.LT. 0.5D0) GO TO 130
34073 C-----------------------------
34074 C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34081 IF(IB1.EQ.IBN) GO TO 140
34087 C-----------------------------
34088 C***IT1,IT2 ARE THE CREATED PARTICLES
34089 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34090 C------------------------
34091 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34092 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34097 C-----------------------------
34098 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34099 C----------------------------
34100 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34101 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34105 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34106 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34109 C-----------------------------
34110 C***TEST STABLE OR UNSTABLE
34111 C----------------------------
34112 IF(ITS(IST).GT.NSTAB) GO TO 160
34115 C-----------------------------
34116 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34117 C----------------------------
34118 C* IF (REDU.LT.0.D0) GO TO 1009
34126 IF(IST.GE.1) GO TO 150
34130 C RANDOM CHOICE OF DECAY CHANNELS
34131 C----------------------------
34145 IF (VV.GT.WTI(IIK)) GO TO 180
34147 C IIK IS THE DECAY CHANNEL
34148 C----------------------------
34156 IF (IT2-1.LT.0) GO TO 240
34161 C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34162 C----------------------------
34163 IF (IECO.LE.10) GO TO 200
34165 IF(IATMPT.GT.3) THEN
34166 C WRITE(LOUT,*) ' jump 4'
34171 IF (I310.GT.50) GO TO 170
34172 IF (AMS.GT.ECO) GO TO 190
34174 C FOR THE DECAY CHANNEL
34175 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
34176 C----------------------------
34177 IF (REDU.LT.0.D0) GO TO 30
34180 IF(IT3.EQ.0) GO TO 220
34183 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34184 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34186 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34187 &COD2,COF2,SIF2,AM1,AM2)
34192 IF (REDU.GT.0.D0) GO TO 240
34194 IF (ITWTHC.GT.100) GO TO 30
34195 IF (ITWTH) 220,220,210
34198 IF (IT2-1.LT.0) GO TO 250
34205 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34206 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34209 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34210 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34211 IF (IT3.LE.0) GO TO 250
34214 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34215 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34223 C----------------------------
34225 C ZERO CROSS SECTION CASE
34226 C----------------------------
34238 *$ CREATE DT_RUNTT.FOR
34241 *===runtt==============================================================*
34243 BLOCK DATA DT_RUNTT
34245 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34248 COMMON /HNDRUN/ RUNTES,EFTES
34250 DATA RUNTES,EFTES /100.D0,100.D0/
34254 *$ CREATE DT_NONAME.FOR
34257 *===noname=============================================================*
34259 BLOCK DATA DT_NONAME
34261 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34264 * slope parameters for HADRIN interactions
34265 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34266 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34268 C DATAS DATAS DATAS DATAS DATAS
34270 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34271 & 207, 224, 241, 252, 268 /
34272 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34273 & 220, 241, 262, 279, 296 /
34274 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34275 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
34278 C MASSES FOR THE SLOPE B(M) IN GEV
34279 C SLOPE B(M) FOR AN MESONIC SYSTEM
34280 C SLOPE B(M) FOR A BARYONIC SYSTEM
34283 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
34284 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
34285 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
34286 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
34287 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
34288 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34289 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
34290 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
34291 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
34292 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
34293 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
34294 & 14.2D0, 13.4D0, 12.6D0,
34295 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
34296 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
34300 *$ CREATE DT_DAMG.FOR
34303 *===damg===============================================================*
34305 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34307 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34310 * particle properties (BAMJET index convention),
34311 * (dublicate of DTPART for HADRIN)
34312 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34313 & K1H(110),K2H(110)
34315 DIMENSION GASUNI(14)
34317 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34318 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34319 DATA GAUNO/2.352D0/
34325 IF (IT.LE.0) GO TO 30
34326 IF (IT.LE.NSTAB) GO TO 20
34327 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34329 VV=VV*2.0D0-1.0D0+1.D-16
34334 IF (VV.GT.V1) GO TO 10
34335 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34336 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34337 DAM=GAH(IT)*UNIGA/GAUNO
34349 *$ CREATE DT_DCALUM.FOR
34352 *===dcalum=============================================================*
34354 SUBROUTINE DT_DCALUM(N,ITTA)
34356 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34359 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34361 * particle properties (BAMJET index convention),
34362 * (dublicate of DTPART for HADRIN)
34363 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34364 & K1H(110),K2H(110)
34365 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34366 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34367 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34368 & NRK(2,268),NURE(30,2)
34370 IRE=NURE(N,ITTA/8+1)
34379 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34386 IF(NRK(2,IK).GT.0) GO TO 30
34395 IF(IN.GT.0)AMS=AMS+AMH(IN)
34397 IF(IN.GT.0) AMS=AMS+AMH(IN)
34398 IF (AMS.LT.AMSS) AMSS=AMS
34400 IF(UMOO.LT.AMSS) UMOO=AMSS
34406 *$ CREATE DT_DCHANH.FOR
34409 *===dchanh=============================================================*
34411 SUBROUTINE DT_DCHANH
34413 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34416 PARAMETER ( LINP = 10 ,
34419 * particle properties (BAMJET index convention),
34420 * (dublicate of DTPART for HADRIN)
34421 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34422 & K1H(110),K2H(110)
34423 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34424 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34425 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34426 & NRK(2,268),NURE(30,2)
34428 DIMENSION HWT(460),HWK(40),SI(5184)
34429 EQUIVALENCE (WK(1),SI(1))
34430 C--------------------
34431 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34432 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34433 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34434 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34435 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34436 C--------------------------
34440 IEE=IEII(IRE+1)-IEII(IRE)
34441 IKE=IKII(IRE+1)-IKII(IRE)
34444 * modifications to suppress elestic scattering 24/07/91
34449 IWK=IWKO+IEE*(IK-1)+IE
34450 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34451 SIS=SIS+SI(IWK)*SINORC
34455 IF (SIS.GE.1.D-12) GO TO 20
34461 IWK=IWKO+IEE*(IK-1)+IE
34462 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34463 SIO=SIO+SI(IWK)*SINORC/SIS
34467 IWK=IWKO+IEE*(IK-1)+IE
34472 INRK1=NRK(1,IIKI+IK)
34473 IF (INRK1.GT.0) AM111=AMH(INRK1)
34475 INRK2=NRK(2,IIKI+IK)
34476 IF (INRK2.GT.0) AM222=AMH(INRK2)
34477 THRESH(IIKI+IK)=AM111 +AM222
34478 IF (INRK2-1.GE.0) GO TO 60
34482 DO 50 INRK1=INRKK,INRKO
34483 INZK1=NZKI(INRK1,1)
34484 INZK2=NZKI(INRK1,2)
34485 INZK3=NZKI(INRK1,3)
34486 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
34487 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
34488 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
34489 C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34491 AMS=AMH(INZK1)+AMH(INZK2)
34492 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34493 IF (AMSS.GT.AMS) AMSS=AMS
34496 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34497 THRESH(IIKI+IK)=AMS
34508 IF (IK2.GT.460)IK2=460
34515 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34516 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34523 *$ CREATE DT_DHADDE.FOR
34526 *===dhadde=============================================================*
34528 SUBROUTINE DT_DHADDE
34530 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34533 * particle properties (BAMJET index convention)
34535 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34536 & IICH(210),IIBAR(210),K1(210),K2(210)
34537 * HADRIN: decay channel information
34538 PARAMETER (IDMAX9=602)
34540 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34541 * particle properties (BAMJET index convention),
34542 * (dublicate of DTPART for HADRIN)
34543 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34544 & K1H(110),K2H(110)
34545 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34546 * decay channel information for HADRIN
34547 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34548 & K1Z(16),K2Z(16),WTZ(153),II22,
34549 & NZK1(153),NZK2(153),NZK3(153)
34555 IF (IRETUR.GT.1) RETURN
34561 IBARH(I) = IIBAR(I)
34576 NZKI(I,1) = NZK(I,1)
34577 NZKI(I,2) = NZK(I,2)
34578 NZKI(I,3) = NZK(I,3)
34593 NZKI(L,3) = NZK3(I)
34594 NZKI(L,2) = NZK2(I)
34595 NZKI(L,1) = NZK1(I)
34600 *$ CREATE IDT_IEFUND.FOR
34603 *===iefund=============================================================*
34605 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34607 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34610 C*****IEFUN CALCULATES A MOMENTUM INDEX
34612 PARAMETER ( LINP = 10 ,
34615 COMMON /HNDRUN/ RUNTES,EFTES
34616 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34617 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34618 & NRK(2,268),NURE(30,2)
34623 IF (PL.LT.0.) GO TO 30
34626 IF (PL.LE.PLABF(I)) GO TO 60
34629 IF ( EFTES.GT.40.D0) GO TO 20
34631 WRITE(LOUT,1000)PL,J
34637 IF (-PL.LE.UMO(I)) GO TO 60
34640 IF ( EFTES.GT.40.D0) GO TO 50
34642 WRITE(LOUT,1000)PL,I
34648 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34652 *$ CREATE DT_DSIGIN.FOR
34655 *===dsigin=============================================================*
34657 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34659 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34662 * particle properties (BAMJET index convention),
34663 * (dublicate of DTPART for HADRIN)
34664 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34665 & K1H(110),K2H(110)
34666 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34667 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34668 & NRK(2,268),NURE(30,2)
34670 IE=IDT_IEFUND(PLAB,IRE)
34671 IF (IE.LE.IEII(IRE)) IE=IE+1
34676 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34677 C*** INTERPOLATION PREPARATION
34683 EKLIM=-THRESH(IIKI)
34686 IF (ECM.GT.ECMO) WDK=0.0D0
34687 C*** INTERPOLATION IN CHANNEL WEIGHTS
34688 IELIM=IDT_IEFUND(EKLIM,IRE)
34689 DELIM=UMO(IELIM)+EKLIM
34691 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34692 IF (DELIM*DELIM-DETE*DETE) 20,20,10
34697 WKK=WOK-WDK*DEC/(DECC+1.D-9)
34698 IF (WKK.LT.0.0D0) WKK=0.0D0
34700 IF (-EKLIM.GT.ECM) SI=1.D-14
34704 *$ CREATE DT_DTCHOI.FOR
34707 *===dtchoi=============================================================*
34709 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34711 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34714 C ****************************
34715 C TCHOIC CALCULATES A RANDOM VALUE
34716 C FOR THE FOUR-MOMENTUM-TRANSFER T
34717 C ****************************
34719 * particle properties (BAMJET index convention),
34720 * (dublicate of DTPART for HADRIN)
34721 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34722 & K1H(110),K2H(110)
34723 * slope parameters for HADRIN interactions
34724 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34728 IF (I.GT.30.AND.II.GT.30) GO TO 20
34731 IF (I.LE.30) GO TO 10
34739 IF (AMA.LE.AMB) GO TO 30
34745 K=INT((AMA-0.75D0)/0.05D0)
34747 IF (K-26.GE.0) K=25
34754 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
34755 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
34758 C IF (VB.LT.0.2D0) BM=BM*0.1
34765 IF (ABS(TMA).GT.120.D0) GO TO 70
34768 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34769 C*** RANDOM CHOICE OF THE T - VALUE
34771 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34775 *$ CREATE DT_DTWOPA.FOR
34778 *===dtwopa=============================================================*
34780 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34781 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34783 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34786 C ******************************************************
34787 C QUASI TWO PARTICLE PRODUCTION
34788 C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34789 C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34790 C IN THE CM - SYSTEM
34791 C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34792 C SPHERICAL COORDINATES
34793 C ******************************************************
34795 * particle properties (BAMJET index convention),
34796 * (dublicate of DTPART for HADRIN)
34797 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34798 & K1H(110),K2H(110)
34803 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34805 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34806 AMTE=(E1-AMA)*(E1+AMA)
34810 C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
34811 C DETERMINATION OF THE ANGLES
34812 C COS(THETA1)=COD1 COS(THETA2)=COD2
34813 C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
34814 C COS(PHI1)=COF1 COS(PHI2)=COF2
34815 C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34816 CALL DT_DSFECF(COF1,SIF1)
34819 C CALCULATION OF THETA1
34820 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34821 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34822 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34827 *$ CREATE DT_ZK.FOR
34830 *===zk=================================================================*
34834 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34837 * decay channel information for HADRIN
34838 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34839 & K1Z(16),K2Z(16),WTZ(153),II22,
34840 & NZK1(153),NZK2(153),NZK3(153)
34841 * decay channel information for HADRIN
34842 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34843 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34845 * Particle masses in GeV *
34846 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34848 * Resonance width Gamma in GeV *
34849 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34850 * Mean life time in seconds *
34851 DATA TAUZ / 16*0.D0 /
34852 * Charge of particles and resonances *
34853 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34854 * Baryonic charge *
34855 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34856 * First number of decay channels used for resonances *
34857 * and decaying particles *
34858 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34860 * Last number of decay channels used for resonances *
34861 * and decaying particles *
34862 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34864 * Weight of decay channel *
34865 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34866 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34867 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34868 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34869 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34870 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34871 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34872 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34873 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34874 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34875 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34876 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34877 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34878 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34879 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34880 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34881 & .05D0, .65D0, 9*1.D0 /
34882 * Particle numbers in decay channel *
34883 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34884 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34885 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34886 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34887 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34888 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34889 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34890 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34891 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34892 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34893 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34894 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34895 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34896 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34897 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34898 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34899 & 1, 8, 1, 8, 1, 9*0 /
34900 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34901 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34902 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34903 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34904 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34905 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34907 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
34908 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34910 * Name of decay channel *
34911 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34912 & 'ANNPI0','APPPI0','ANPPI-'/
34913 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
34914 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
34915 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
34916 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34917 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34918 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34919 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34921 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
34922 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34923 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34924 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34925 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
34926 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34927 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34928 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34929 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
34930 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34931 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34932 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34933 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34938 *$ CREATE DT_BLKD43.FOR
34941 *===blkd43=============================================================*
34943 BLOCK DATA DT_BLKD43
34945 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34949 *=== reac =============================================================*
34951 *----------------------------------------------------------------------*
34953 * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
34956 * Last change on 10-dec-91 by Alfredo Ferrari *
34958 * This is the original common reac of Hadrin *
34960 *----------------------------------------------------------------------*
34962 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34963 & NRK(2,268),NURE(30,2)
34966 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34967 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34968 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34969 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34970 & SPIKP5(187), SPIKP6(289),
34971 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34972 & SPIKP9(143), SPIKP0(169), SPKPV(143),
34973 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34974 & SANPEL(84) , SPIKPF(273),
34975 & SPKP15(187), SPKP16(272),
34976 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34979 DIMENSION NRKLIN(532)
34980 EQUIVALENCE (NRK(1,1), NRKLIN(1))
34981 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
34982 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
34983 EQUIVALENCE ( UMO(263), UMOK0(1))
34984 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
34985 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
34986 EQUIVALENCE ( PLABF(263), PLAK0(1))
34987 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
34988 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
34989 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
34990 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
34991 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
34992 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
34993 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
34994 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
34995 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
34996 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
34997 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
34998 EQUIVALENCE ( WK(4913), SPKP16(1))
34999 EQUIVALENCE (NRK(1,1), NRKLIN(1))
35000 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
35001 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
35002 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
35003 EQUIVALENCE (NURE(1,1), NURELN(1))
35007 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
35008 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
35009 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
35010 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
35011 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
35012 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
35013 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
35014 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
35015 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
35016 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
35018 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35019 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35020 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35021 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35022 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35023 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35024 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35025 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35026 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35027 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35028 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35029 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35031 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35032 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35033 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35034 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35035 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35036 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35039 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35040 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35041 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35042 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35043 & 0.D0, 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 * app apn anp ann *
35047 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35048 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35049 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35050 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35051 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35052 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35053 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35054 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35055 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35056 DATA SIIN / 296*0.D0 /
35057 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35058 & 1.557D0,1.615D0,1.6435D0,
35059 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35060 & 2.286D0,2.366D0,2.482D0,2.56D0,
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.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35068 & 1.496D0,1.527D0,1.557D0,
35069 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35070 & 2.071D0,2.159D0,2.286D0,2.366D0,
35071 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35072 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35073 & 1.557D0,1.615D0,1.6435D0,
35074 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35075 & 2.286D0,2.366D0,2.482D0,2.56D0,
35077 DATA UMOKC/ 1.44D0,
35078 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35079 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35081 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35082 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35084 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35085 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35087 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35088 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35090 DATA UMOK0/ 1.44D0,
35091 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35092 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35094 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35095 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35099 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35100 & 3.D0,3.1D0,3.2D0,
35101 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35102 & 3.D0,3.1D0,3.2D0,
35103 & 1.88D0,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 * app apn anp ann *
35107 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35108 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35109 & 3.D0,3.1D0,3.2D0,
35110 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35111 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35112 & 3.D0,3.1D0,3.2D0,
35113 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35114 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35115 & 3.D0,3.1D0,3.2D0/
35116 **** reaction channel state particles *
35117 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35118 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35119 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35120 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35121 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35122 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35123 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35124 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35125 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35126 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35127 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35128 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35129 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35130 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35131 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35132 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35133 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35134 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35136 * k0 p k0 n ak0 p ak/ n *
35138 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35139 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
35140 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35141 & 53, 47, 1, 103, 0, 93, 0/
35143 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35144 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35145 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35146 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35147 * app apn anp ann *
35148 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35149 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35150 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35151 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35152 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35153 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35154 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35155 **** channel cross section *
35156 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35157 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35158 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35159 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35160 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35161 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35162 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35163 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35164 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35165 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35166 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35167 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35168 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35169 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35170 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35171 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35172 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35173 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35174 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35175 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35177 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
35178 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35179 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35180 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35181 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
35182 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
35183 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
35184 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
35185 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
35186 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
35187 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
35188 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
35189 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
35190 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
35191 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35192 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
35193 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
35194 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
35195 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
35196 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35198 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35199 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35200 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35201 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35202 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35203 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35204 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35205 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35206 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35207 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35208 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35209 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35210 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35211 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35212 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35213 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35214 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35215 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35216 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35217 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35219 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35220 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35221 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35222 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35223 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35224 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35225 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35226 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35227 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35228 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35229 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35230 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35231 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35232 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35233 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35234 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35235 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35236 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35237 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35239 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35240 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35241 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35242 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35243 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35244 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35245 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35246 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35247 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35248 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35249 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35250 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35251 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35252 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35253 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35254 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35255 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35256 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35257 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35258 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35260 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35261 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35262 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35263 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35264 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35265 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35266 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35267 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35268 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35269 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35270 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35271 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35272 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35273 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35274 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35275 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35276 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35277 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35278 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35279 & 3.3D0, 5.4D0, 7.D0 /
35281 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35282 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35283 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35284 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35285 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35286 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35287 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35288 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35289 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35290 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35291 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35292 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35293 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35295 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35296 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35297 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35298 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35299 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35300 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35301 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35302 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35303 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35304 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35305 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35306 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35307 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35308 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35309 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35310 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35311 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35312 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35313 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35315 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35316 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35317 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35318 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35319 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35320 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35321 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35322 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35323 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35324 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35325 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35326 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35327 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35328 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35329 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35330 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35331 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
35332 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35333 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35334 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35335 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35336 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35337 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35338 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35339 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35340 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35341 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35342 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35343 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35344 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35345 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35346 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35349 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35350 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35351 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35352 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35353 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35354 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35355 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35356 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35357 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35358 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35359 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35360 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35361 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35362 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35363 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35364 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35365 & .39D0, .22D0, .07D0, 0.D0,
35366 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35367 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35368 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35369 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35370 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35371 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35372 & 5.10D0, 5.44D0, 5.3D0,
35373 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35375 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35376 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35377 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
35378 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35379 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35380 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35381 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35382 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35383 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35384 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35385 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35386 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35387 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35388 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35389 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35391 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35392 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35393 & 0.D0, 1.8D0, .2D0, 12*0.D0,
35394 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35395 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35396 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35397 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35398 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35399 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35400 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35401 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35402 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35403 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35404 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35405 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35406 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35407 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35408 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35411 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35412 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35413 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
35414 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35415 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35416 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35417 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35418 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35419 & 11.D0, 5.5D0, 3.5D0,
35420 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35421 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35422 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35423 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35424 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35425 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35426 **************** ap - p - data *
35427 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35428 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35429 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35430 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35431 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35432 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35433 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35434 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35435 & 1.55D0, 1.3D0, .95D0, .75D0,
35436 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35437 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35438 & .01D0, .008D0, .006D0, .005D0/
35439 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35440 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35441 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35442 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35443 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35444 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35445 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35446 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35447 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35448 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35449 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35450 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35451 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35452 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35453 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35454 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35455 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35456 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35457 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35458 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35459 **************** ap - n - data *
35461 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35462 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35463 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35464 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
35465 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
35466 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35467 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35468 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35469 & .01D0, .008D0, .006D0, .005D0 /
35470 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35471 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35472 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35473 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35474 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35475 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35476 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35477 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35478 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35479 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35480 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35481 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35482 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35483 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35486 **************** an - p - data *
35489 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35490 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35491 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
35492 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35493 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35494 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35495 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35496 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35497 & .01D0, .008D0, .006D0, .005D0 /
35498 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35499 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35500 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35501 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35502 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35503 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35504 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35505 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35506 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35507 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35508 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35509 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35510 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35511 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35512 **** ko - n - data *
35513 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35514 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35515 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35516 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35517 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35518 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35519 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35520 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35521 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
35522 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35523 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35525 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35526 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35527 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
35528 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35529 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
35530 **** ako - p - data *
35531 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35532 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35533 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35534 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35535 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35536 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35537 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35538 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35539 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35540 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35541 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35542 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35543 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35544 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35545 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35546 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35547 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35548 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35549 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35550 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35551 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35552 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35553 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35554 *= end*block.blkdt3 *
35557 *$ CREATE DT_QEL_POL.FOR
35560 *===qel_pol============================================================*
35562 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35564 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35568 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35573 *$ CREATE DT_GEN_QEL.FOR
35575 C==================================================================
35576 C Generation of a Quasi-Elastic neutrino scattering
35577 C==================================================================
35579 *===gen_qel============================================================*
35581 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35583 C...Generate a quasi-elastic neutrino/antineutrino
35584 C. Interaction on a nuclear target
35585 C. INPUT : LTYP = neutrino type (1,...,6)
35586 C. ENU (GeV) = neutrino energy
35587 C----------------------------------------------------
35589 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35592 PARAMETER ( LINP = 10 ,
35595 PARAMETER (MAXLND=4000)
35596 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35597 * nuclear potential
35599 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35600 & EBINDP(2),EBINDN(2),EPOT(2,210),
35601 & ETACOU(2),ICOUL,LFERMI
35602 * steering flags for qel neutrino scattering modules
35603 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35604 **sr - removed (not needed)
35605 C COMMON /CBAD/ LBAD, NBAD
35606 C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35609 DIMENSION PI(3),PO(3)
35614 C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35615 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35616 DATA AMN /0.93827231D0, 0.93956563D0/
35617 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35620 C DATA PFERMI/0.22D0/
35621 CGB+...Binding Energy
35622 DATA EBIND/0.008D0/
35626 IF(ININU.EQ.1)NDSIG=0
35631 AML = AML0(LTYP) ! massa leptoni
35632 AML2 = AML**2 ! massa leptoni **2
35633 C...Particle labels (LUND)
35643 K0 = (LTYP-1)/2 ! 2
35645 KA = 12 + 2*K0 ! 16
35646 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
35650 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
35651 IF (LNU .EQ. 2) THEN
35679 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
35680 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35685 C...4-momentum initial lepton
35686 P(1,5) = 0. ! massa
35687 P(1,4) = ENU0 ! energia
35692 C PF = PFERMI*PYR(0)**(1./3.)
35693 c write(23,*) PYR(0)
35694 c write(*,*) 'Pfermi=',PF
35697 C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35698 IF (NTRY .GT. 500) THEN
35700 WRITE (LOUT,1001) NBAD, ENU
35703 C CT = -1. + 2.*PYR(0)
35705 C ST = SQRT(1.-CT*CT)
35706 C F = 2.*3.1415926*PYR(0)
35709 C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
35710 C P(2,1) = PF*ST*COS(F) ! px
35711 C P(2,2) = PF*ST*SIN(F) ! py
35712 C P(2,3) = PF*CT ! pz
35713 C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
35719 beta1=-p(2,1)/p(2,4)
35720 beta2=-p(2,2)/p(2,4)
35721 beta3=-p(2,3)/p(2,4)
35723 C WRITE(6,*)' before transforming into target rest frame'
35724 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35725 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35728 phi11=atan(p(1,2)/p(1,3))
35733 CALL DT_TESTROT(PI,Po,PHI11,1)
35735 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35741 phi12=atan(p(1,1)/p(1,3))
35746 CALL DT_TESTROT(Pi,Po,PHI12,2)
35748 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35757 C...Kinematical limits in Q**2
35758 c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
35759 S = P(2,5)**2 + 2.*ENU*P(2,5)
35760 SQS = SQRT(S) ! E centro massa
35761 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35762 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
35763 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
35764 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
35765 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
35766 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
35767 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
35770 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35771 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35772 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35773 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35774 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35776 C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35777 C &Q2,Q2min,Q2MAX,DSIGEV
35779 C...c.m. frame. Neutrino along z axis
35780 DETOT = (P(1,4)) + (P(2,4)) ! e totale
35781 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35782 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35783 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35786 C WRITE(*,*) 'Input values laboratory frame'
35789 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35792 c STHETA = ULANGL(P(1,3),P(1,1))
35793 c write(*,*) 'stheta' ,stheta
35795 c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35798 C WRITE(*,*) 'Output values cm frame'
35799 C...Kinematic in c.m. frame
35800 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35801 STSTAR = SQRT(1.-CTSTAR**2)
35802 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35803 P(4,5) = AML ! massa leptone
35804 P(4,4) = ELF ! e leptone
35805 P(4,3) = PLF*CTSTAR ! px
35806 P(4,1) = PLF*STSTAR*COS(PHI) ! py
35807 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35809 P(5,5) = AMF ! barione
35810 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35811 P(5,3) = -P(4,3) ! px
35812 P(5,1) = -P(4,1) ! py
35813 P(5,2) = -P(4,2) ! pz
35816 P(3,1) = P(1,1)-P(4,1)
35817 P(3,2) = P(1,2)-P(4,2)
35818 P(3,3) = P(1,3)-P(4,3)
35819 P(3,4) = P(1,4)-P(4,4)
35821 C...Transform back to laboratory frame
35822 C WRITE(*,*) 'before going back to nucl rest frame'
35823 c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35826 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35828 C WRITE(*,*) 'Now back in nucl rest frame'
35829 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35831 c********************************************
35837 CALL DT_TESTROT(Pi,Po,PHI12,3)
35839 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35845 c********************************************
35851 CALL DT_TESTROT(Pi,Po,PHI11,4)
35853 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35860 c********************************************
35862 C WRITE(*,*) 'Now back in lab frame'
35864 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35867 C...test (on final momentum of nucleon) if Fermi-blocking
35869 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35871 IF (ENUCL.LT. EFMAX) THEN
35872 IF(INIPRI.LT.10)THEN
35874 C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35875 C...the interaction is not possible due to Pauli-Blocking and
35876 C...it must be resampled
35879 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35880 IF(INIPRI.LT.10)THEN
35882 C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35884 C Reject (J:R) here all these events
35885 C are otherwise rejected in dpmjet
35887 C...the interaction is possible, but the nucleon remains inside
35888 C...the nucleus. The nucleus is therefore left excited.
35889 C...We treat this case as a nucleon with 0 kinetic energy.
35895 ELSE IF (ENUCL.GE.ENWELL) THEN
35896 C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35897 C...the interaction is possible, the nucleon can exit the nucleus
35898 C...but the nuclear well depth must be subtracted. The nucleus could be
35899 C...left in an excited state.
35900 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35901 C P(5,4) = ENUCL-ENWELL + AMF
35902 Pnucl = SQRT(P(5,4)**2-AMF**2)
35903 C...The 3-momentum is scaled assuming that the direction remains
35905 P(5,1) = P(5,1) * Pnucl/Pstart
35906 P(5,2) = P(5,2) * Pnucl/Pstart
35907 P(5,3) = P(5,3) * Pnucl/Pstart
35908 C WRITE(6,*)' qel new P(5,4) ',P(5,4)
35911 DSIGSU=DSIGSU+DSIGEV
35921 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35923 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35927 C PRINT*,' FINE EVENTO '
35931 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
35934 *$ CREATE DT_MASS_INI.FOR
35936 C====================================================================
35938 C====================================================================
35940 *===mass_ini===========================================================*
35942 SUBROUTINE DT_MASS_INI
35943 C...Initialize the kinematics for the quasi-elastic cross section
35945 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35948 * particle masses used in qel neutrino scattering modules
35949 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35950 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35951 & EMPROTSQ,EMNEUTSQ,EMNSQ
35953 EML(1) = 0.51100D-03 ! e-
35954 EML(2) = EML(1) ! e+
35955 EML(3) = 0.105659D0 ! mu-
35956 EML(4) = EML(3) ! mu+
35957 EML(5) = 1.7777D0 ! tau-
35958 EML(6) = EML(5) ! tau+
35959 EMPROT = 0.93827231D0 ! p
35960 EMNEUT = 0.93956563D0 ! n
35961 EMPROTSQ = EMPROT**2
35962 EMNEUTSQ = EMNEUT**2
35963 EMN = (EMPROT + EMNEUT)/2.
35967 EMN1(J0+1) = EMNEUT
35968 EMN1(J0+2) = EMPROT
35969 EMN2(J0+1) = EMPROT
35970 EMN2(J0+2) = EMNEUT
35973 EMLSQ(J) = EML(J)**2
35974 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35979 *$ CREATE DT_DSQEL_Q2.FOR
35982 *===dsqel_q2===========================================================*
35984 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35986 C...differential cross section for Quasi-Elastic scattering
35987 C. nu + N -> l + N'
35988 C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
35990 C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
35991 C. ENU (GeV) = Neutrino energy
35992 C. Q2 (GeV**2) = (Transfer momentum)**2
35994 C. OUTPUT : DSQEL_Q2 = differential cross section :
35995 C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
35996 C------------------------------------------------------------------
35998 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36001 * particle masses used in qel neutrino scattering modules
36002 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36003 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36004 & EMPROTSQ,EMNEUTSQ,EMNSQ
36005 **sr - removed (not needed)
36006 C COMMON /CAXIAL/ FA0, AXIAL2
36010 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36011 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36012 DATA AXIAL2 /1.03D0/ ! to be checked
36016 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
36017 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
36018 X = Q2/(EMN*EMN) ! emn=massa barione
36020 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36021 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36022 FA = FA0/(1.D0 + Q2/AXIAL2)**2
36026 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
36027 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
36028 A2 = -RM * ((FV1 + FV2)**2 + FFA)
36029 AA = (XA+0.25D0*RM)*(A1 + A2)
36030 BB = -X*FA*(FV1 + FV2)
36031 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
36032 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36033 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
36034 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
36039 *$ CREATE DT_PREPOLA.FOR
36042 *===prepola============================================================*
36044 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36046 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36049 c By G. Battistoni and E. Scapparone (sept. 1997)
36051 c Albright & Jarlskog, Nucl Phys B84 (1975) 467
36054 PARAMETER (MAXLND=4000)
36055 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36056 COMMON /QNPOL/ POLARX(4),PMODUL
36057 * particle masses used in qel neutrino scattering modules
36058 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36059 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36060 & EMPROTSQ,EMNEUTSQ,EMNSQ
36061 * steering flags for qel neutrino scattering modules
36062 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36063 **sr - removed (not needed)
36064 C COMMON /CAXIAL/ FA0, AXIAL2
36065 C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36066 C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36068 REAL*8 POL(4,4),BB2(3)
36070 C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36071 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36072 **sr uncommented since common block CAXIAL is now commented
36073 DATA AXIAL2 /1.03D0/ ! to be checked
36083 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
36084 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
36085 X = Q2/(EMN*EMN) ! emn=massa barione
36087 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36088 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36089 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36093 FP=2.D0*FA*RMM/(MPI**2 + Q2)
36094 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
36095 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36096 A2 = -RM * ((FV1 + FV2)**2 + FFA)
36097 AA = (XA+0.25D+00*RM)*(A1 + A2)
36098 BB = -X*FA*(FV1 + FV2)
36099 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36100 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36102 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
36104 OMEGA3=2.D+00*FA*(FV1+FV2)
36105 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36108 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36109 WW1=2.D+00*OMEGA1*EMN**2
36110 WW2=2.D+00*OMEGA2*EMN**2
36111 WW3=2.D+00*OMEGA3*EMN**2
36112 WW4=2.D+00*OMEGA4*EMN**2
36113 WW5=2.D+00*OMEGA5*EMN**2
36116 BB2(I)=-P(4,I)/P(4,4)
36120 c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36122 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36123 * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
36126 c WRITE(*,*) 'Prepola: now in lepton rest frame'
36130 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36131 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36132 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36134 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36135 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
36137 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36140 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36146 PMODUL=PMODUL+POL(4,I)**2
36149 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36150 IF(NEUDEC.EQ.1) THEN
36151 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36153 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36155 c Tau has decayed in muon
36158 IF(NEUDEC.EQ.2) THEN
36159 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36161 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36163 c Tau has decayed in electron
36171 c fill common for muon(electron)
36179 IF(NEUDEC.EQ.1) THEN
36182 ELSEIF(NEUDEC.EQ.2) THEN
36186 ELSEIF(JTYP.EQ.6) THEN
36187 IF(NEUDEC.EQ.1) THEN
36189 ELSEIF(NEUDEC.EQ.2) THEN
36197 c fill common for tau_(anti)neutrino
36207 ELSEIF(JTYP.EQ.6) THEN
36214 c Fill common for muon(electron)_(anti)neutrino
36223 IF(NEUDEC.EQ.1) THEN
36225 ELSEIF(NEUDEC.EQ.2) THEN
36228 ELSEIF(JTYP.EQ.6) THEN
36229 IF(NEUDEC.EQ.1) THEN
36231 ELSEIF(NEUDEC.EQ.2) THEN
36242 c IF(PMODUL.GE.1.D+00) THEN
36243 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36244 c write(*,*) pmodul
36246 c POL(4,I)=POL(4,I)/PMODUL
36247 c POLARX(I)=POL(4,I)
36251 c PMODUL=PMODUL+POL(4,I)**2
36253 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36257 c WRITE(*,*) 'PMODUL = ',PMODUL
36261 c WRITE(*,*) 'prepola: Now back to nucl rest frame'
36262 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36264 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36265 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36266 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36276 *$ CREATE DT_TESTROT.FOR
36279 *===testrot============================================================*
36281 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36283 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36286 DIMENSION ROT(3,3),PI(3),PO(3)
36288 IF (MODE.EQ.1) THEN
36293 ROT(2,2) = COS(PHI)
36294 ROT(2,3) = -SIN(PHI)
36296 ROT(3,2) = SIN(PHI)
36297 ROT(3,3) = COS(PHI)
36298 ELSEIF (MODE.EQ.2) THEN
36302 ROT(2,1) = COS(PHI)
36304 ROT(2,3) = -SIN(PHI)
36305 ROT(3,1) = SIN(PHI)
36307 ROT(3,3) = COS(PHI)
36308 ELSEIF (MODE.EQ.3) THEN
36312 ROT(1,2) = COS(PHI)
36314 ROT(3,2) = -SIN(PHI)
36315 ROT(1,3) = SIN(PHI)
36317 ROT(3,3) = COS(PHI)
36318 ELSEIF (MODE.EQ.4) THEN
36323 ROT(2,2) = COS(PHI)
36324 ROT(3,2) = -SIN(PHI)
36326 ROT(2,3) = SIN(PHI)
36327 ROT(3,3) = COS(PHI)
36329 STOP ' TESTROT: mode not supported!'
36332 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36338 *$ CREATE DT_LEPDCYP.FOR
36341 *===lepdcyp============================================================*
36343 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36344 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36346 C-----------------------------------------------------------------
36348 C Author :- G. Battistoni 10-NOV-1995
36350 C=================================================================
36352 C Purpose : performs decay of polarized lepton in
36353 C its rest frame: a => b + l + anti-nu
36354 C (Example: mu- => nu-mu + e- + anti-nu-e)
36355 C Polarization is assumed along Z-axis
36357 C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36358 C OF NEGLIGIBLE MASS
36359 C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36362 C Method : modifies phase space distribution obtained
36363 C by routine EXPLOD using a rejection against the
36364 C matrix element for unpolarized lepton decay
36366 C Inputs : Mass of a : AMA
36369 C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36372 C Outputs : kinematic variables in the rest frame of decaying lepton
36373 C ETL,PXL,PYL,PZL 4-moment of l
36374 C ETB,PXB,PYB,PZB 4-moment of b
36375 C ETN,PXN,PYN,PZN 4-moment of anti-nu
36377 C============================================================
36381 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36384 PARAMETER ( LINP = 10 ,
36387 PARAMETER ( KALGNM = 2 )
36388 PARAMETER ( ANGLGB = 5.0D-16 )
36389 PARAMETER ( ANGLSQ = 2.5D-31 )
36390 PARAMETER ( AXCSSV = 0.2D+16 )
36391 PARAMETER ( ANDRFL = 1.0D-38 )
36392 PARAMETER ( AVRFLW = 1.0D+38 )
36393 PARAMETER ( AINFNT = 1.0D+30 )
36394 PARAMETER ( AZRZRZ = 1.0D-30 )
36395 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36396 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36397 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
36398 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
36399 PARAMETER ( CSNNRM = 2.0D-15 )
36400 PARAMETER ( DMXTRN = 1.0D+08 )
36401 PARAMETER ( ZERZER = 0.D+00 )
36402 PARAMETER ( ONEONE = 1.D+00 )
36403 PARAMETER ( TWOTWO = 2.D+00 )
36404 PARAMETER ( THRTHR = 3.D+00 )
36405 PARAMETER ( FOUFOU = 4.D+00 )
36406 PARAMETER ( FIVFIV = 5.D+00 )
36407 PARAMETER ( SIXSIX = 6.D+00 )
36408 PARAMETER ( SEVSEV = 7.D+00 )
36409 PARAMETER ( EIGEIG = 8.D+00 )
36410 PARAMETER ( ANINEN = 9.D+00 )
36411 PARAMETER ( TENTEN = 10.D+00 )
36412 PARAMETER ( HLFHLF = 0.5D+00 )
36413 PARAMETER ( ONETHI = ONEONE / THRTHR )
36414 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36415 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36416 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36417 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36418 PARAMETER ( CLIGHT = 2.99792458 D+10 )
36419 PARAMETER ( AVOGAD = 6.0221367 D+23 )
36420 PARAMETER ( AMELGR = 9.1093897 D-28 )
36421 PARAMETER ( PLCKBR = 1.05457266 D-27 )
36422 PARAMETER ( ELCCGS = 4.8032068 D-10 )
36423 PARAMETER ( ELCMKS = 1.60217733 D-19 )
36424 PARAMETER ( AMUGRM = 1.6605402 D-24 )
36425 PARAMETER ( AMMUMU = 0.113428913 D+00 )
36426 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36427 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36428 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36429 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36430 PARAMETER ( PLABRC = 0.197327053 D+00 )
36431 PARAMETER ( AMELCT = 0.51099906 D-03 )
36432 PARAMETER ( AMUGEV = 0.93149432 D+00 )
36433 PARAMETER ( AMMUON = 0.105658389 D+00 )
36434 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36435 PARAMETER ( GEVMEV = 1.0 D+03 )
36436 PARAMETER ( EMVGEV = 1.0 D-03 )
36437 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
36438 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36439 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36441 C variables for EXPLOD
36443 PARAMETER ( KPMX = 10 )
36444 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36445 & PZEXPL (KPMX), ETEXPL (KPMX)
36449 **sr - removed (not needed)
36450 C COMMON /GBATNU/ ELERAT,NTRY
36453 C Initializes test variables
36458 C Maximum value for matrix element
36460 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36461 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36462 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36463 C Inputs for EXPLOD
36464 C part. no. 1 is l (e- in mu- decay)
36465 C part. no. 2 is b (nu-mu in mu- decay)
36466 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36467 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36474 C phase space distribution
36479 CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36483 C Calculates matrix element:
36484 C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36485 C Here CTH is the cosine of the angle between anti-nu and Z axis
36487 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36489 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36490 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36491 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36492 ELEMAT = 16.D+00 * PROD1 * PROD2
36493 IF(ELEMAT.GT.ELEMAX) THEN
36494 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36498 C Here performs the rejection
36500 TEST = DT_RNDM(ETOTEX) * ELEMAX
36501 IF ( TEST .GT. ELEMAT ) GO TO 100
36503 C final assignment of variables
36505 ELERAT = ELEMAT/ELEMAX
36521 *$ CREATE DT_GEN_DELTA.FOR
36523 C==================================================================
36524 C. Generation of Delta resonance events
36525 C==================================================================
36527 *===gen_delta==========================================================*
36529 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36531 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36534 PARAMETER ( LINP = 10 ,
36537 C...Generate a Delta-production neutrino/antineutrino
36538 C. CC-interaction on a nucleon
36540 C. INPUT ENU (GeV) = Neutrino Energy
36541 C. LLEP = neutrino type
36542 C. LTARG = nucleon target type 1=p, 2=n.
36543 C. JINT = 1:CC, 2::NC
36545 C. OUTPUT PPL(4) 4-monentum of final lepton
36546 C----------------------------------------------------
36547 PARAMETER (MAXLND=4000)
36548 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36549 **sr - removed (not needed)
36550 C COMMON /CBAD/ LBAD, NBAD
36553 DIMENSION PI(3),PO(3)
36554 C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36555 DIMENSION AML0(6),AMN(2)
36556 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36557 DATA AMN /0.93827231, 0.93956563/
36558 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36560 c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36562 C...Final lepton mass
36563 IF (JINT.EQ.1) THEN
36570 C...Particle labels (LUND)
36578 IF (LTARG .EQ. 1) THEN
36586 IS = -1 + 2*LLEP - 4*K1
36587 LNU = 2 - LLEP + 2*K1
36591 IF (JINT .EQ. 1) THEN ! CC interactions
36595 IF (LTARG .EQ. 1) THEN
36601 IF (LTARG .EQ. 1) THEN
36608 K(3,2) = 23 ! NC (Z0) interactions
36610 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36611 * Delta0 for neutron (LTARG=2)
36612 C IF (LTARG .EQ. 1) THEN
36617 IF (LTARG .EQ. 1) THEN
36625 C...4-momentum initial lepton
36631 C...4-momentum initial nucleon
36632 P(2,5) = AMN(LTARG)
36643 beta1=-p(2,1)/p(2,4)
36644 beta2=-p(2,2)/p(2,4)
36645 beta3=-p(2,3)/p(2,4)
36648 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36650 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36652 phi11=atan(p(1,2)/p(1,3))
36657 CALL DT_TESTROT(PI,Po,PHI11,1)
36659 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36664 phi12=atan(p(1,1)/p(1,3))
36669 CALL DT_TESTROT(Pi,Po,PHI12,2)
36671 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36679 C...Generate the Mass of the Delta
36682 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36684 IF (NTRY .GT. 1000) THEN
36686 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36689 IF (AMD .LT. AMDMIN) GOTO 100
36690 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36691 IF (ENUU .LT. ET) GOTO 100
36693 C...Kinematical limits in Q**2
36694 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36696 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36697 ELF = (S - AMD**2 + AML2)/(2.*SQS)
36698 PLF = SQRT(ELF**2 - AML2)
36699 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36700 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36701 IF (Q2MIN .LT. 0.) Q2MIN = 0.
36703 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36704 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36705 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36706 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
36708 C...Generate the kinematics of the final particles
36709 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36710 GAM = EISTAR/AMN(LTARG)
36712 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36713 EL = GAM*(ELF + BET*PLF*CTSTAR)
36714 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36715 PL = SQRT(EL**2 - AML2)
36716 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36717 PHI = 6.28319*PYR(0)
36718 P(4,1) = PLT*COS(PHI)
36719 P(4,2) = PLT*SIN(PHI)
36724 C...4-momentum of Delta
36727 P(5,3) = ENUU-P(4,3)
36728 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36731 C...4-momentum of intermediate boson
36733 P(3,4) = P(1,4)-P(4,4)
36734 P(3,1) = P(1,1)-P(4,1)
36735 P(3,2) = P(1,2)-P(4,2)
36736 P(3,3) = P(1,3)-P(4,3)
36743 CALL DT_TESTROT(Pi,Po,PHI12,3)
36745 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36752 c********************************************
36758 CALL DT_TESTROT(Pi,Po,PHI11,4)
36760 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36766 c********************************************
36767 C transform back into Lab.
36769 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36771 C WRITE(6,*)' Lab fram ( fermi incl.) '
36776 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
36779 *$ CREATE DT_DSIGMA_DELTA.FOR
36780 *COPY DT_DSIGMA_DELTA
36782 *===dsigma_delta=======================================================*
36784 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36786 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36789 C...Reaction nu + N -> lepton + Delta
36790 C. returns the cross section
36792 C. INPUT LNU = 1, 2 (neutrino-antineutrino)
36793 C. QQ = t (always negative) GeV**2
36794 C. S = (c.m energy)**2 GeV**2
36795 C. OUTPUT = 10**-38 cm+2/GeV**2
36796 C-----------------------------------------------------
36797 REAL*8 MN, MN2, MN4, MD,MD2, MD4
36799 DATA PI /3.1415926/
36801 GF = (1.1664 * 1.97)
36809 VQ = (MN2 - MD2 - QQ)/2.
36810 VPI = (MN2 + MD2 - QQ)/2.
36811 VK = (S + QQ - MN2 - AML2)/2.
36813 QK = (AML2 - QQ)/2.
36814 PIQ = (QQ + MN2 - MD2)/2.
36816 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36817 C3 = SQRT(3.)*C3V/MN
36818 C4 = -C3/MD ! attenzione al segno
36819 C5A = 1.18/(1.-QQ/0.4225)**2
36824 IF (LNU .EQ. 1) THEN
36825 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36826 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36827 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36828 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36829 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36830 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36831 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36832 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36833 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36834 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36835 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36836 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36837 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36838 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36839 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36840 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36841 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36842 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36843 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36844 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36845 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36846 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36847 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36849 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36850 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36851 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36852 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36853 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36854 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36855 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36856 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36857 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36858 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36859 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36860 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36861 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36862 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36863 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36864 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36865 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36866 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36867 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36868 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36869 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36870 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36871 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36875 P1CM = (S-MN2)/(2.*SQRT(S))
36876 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36881 *$ CREATE DT_QGAUS.FOR
36884 *===qgaus==============================================================*
36886 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36891 DIMENSION X(5),W(5)
36892 DATA X/.1488743389D0,.4333953941D0,
36893 & .6794095682D0,.8650633666D0,.9739065285D0
36895 DATA W/.2955242247D0,.2692667193D0,
36896 & .2190863625D0,.1494513491D0,.0666713443D0
36903 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36904 * DT_DSQEL_Q2(LTYP,ENU,XM-DX))
36911 *$ CREATE DT_DIQBRK.FOR
36914 *===diqbrk=============================================================*
36916 SUBROUTINE DT_DIQBRK
36918 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36922 PARAMETER (NMXHKK=200000)
36923 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36924 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36925 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36926 * extended event history
36927 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36928 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36931 COMMON /DTEVNO/ NEVENT,ICASCA
36933 C IF(DT_RNDM(VV).LE.0.5D0)THEN
36934 C CALL GSQBS1(NHKK)
36935 C CALL GSQBS2(NHKK)
36936 C CALL USQBS1(NHKK)
36937 C CALL USQBS2(NHKK)
36938 C CALL GSABS1(NHKK)
36939 C CALL GSABS2(NHKK)
36940 C CALL USABS1(NHKK)
36941 C CALL USABS2(NHKK)
36943 C CALL GSQBS2(NHKK)
36944 C CALL GSQBS1(NHKK)
36945 C CALL USQBS2(NHKK)
36946 C CALL USQBS1(NHKK)
36947 C CALL GSABS2(NHKK)
36948 C CALL GSABS1(NHKK)
36949 C CALL USABS2(NHKK)
36950 C CALL USABS1(NHKK)
36953 IF(DT_RNDM(VV).LE.0.5D0) THEN
36976 *$ CREATE MUSQBS2.FOR
36980 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36981 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36982 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36984 C USQBS-2 diagram (split target diquark)
36986 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36989 PARAMETER ( LINP = 10 ,
36993 PARAMETER (NMXHKK=200000)
36994 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36995 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36996 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36997 * extended event history
36998 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36999 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37001 * Lorentz-parameters of the current interaction
37002 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37003 & UMO,PPCM,EPROJ,PPROJ
37004 * diquark-breaking mechanism
37005 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37008 PARAMETER (NTMHKK= 300)
37009 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37010 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37013 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37016 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37017 COMMON /EVFLAG/ NUMEV
37019 C USQBS-2 diagram (split target diquark)
37022 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37023 C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
37025 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37026 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37028 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37029 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37030 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37033 C Put new chains into COMMON /HKKTMP/
37038 C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37042 C IF(NUMEV.EQ.-324)THEN
37043 C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37044 C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37045 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37046 C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37051 C determine x-values of NC1T diquark
37052 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37053 XVQP=PHKK(4,NC1P)*2.D0/UMO
37055 C determine x-values of sea quark pair
37061 IF(ICOU.GE.500)THEN
37064 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37068 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37073 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37074 IF (IPIP.EQ.1) THEN
37075 XQMAX = XDIQT/2.0D0
37076 XAQMAX = 2.D0*XVQP/3.0D0
37078 XQMAX = 2.D0*XVQP/3.0D0
37079 XAQMAX = XDIQT/2.0D0
37081 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37083 C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37086 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37089 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37094 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37095 ELSEIF(IPIP.EQ.2)THEN
37096 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37099 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37100 * XDIQT,XVQP,XSQ,XSAQ
37103 C subtract xsq,xsaq from NC1T diquark and NC1P quark
37109 ELSEIF(IPIP.EQ.2)THEN
37114 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37116 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37121 IF(IVTHR.EQ.10)THEN
37124 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37129 XVTHR=XVTHRO/(201-IVTHR)
37132 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37135 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ',
37140 IF(DT_RNDM(V).LT.0.5D0)THEN
37141 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37144 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37148 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37151 C Prepare 4 momenta of new chains and chain ends
37153 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37154 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37157 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37158 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37159 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37161 C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37162 C * IP1,IP21,IP22,IPP1,IPP2)
37169 ELSEIF(IPIP.EQ.2)THEN
37179 JDAHKT(1,1)=3+IIGLU1
37181 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37182 PHKT(1,1) =PHKK(1,NC2P)
37183 PHKT(2,1) =PHKK(2,NC2P)
37184 PHKT(3,1) =PHKK(3,NC2P)
37185 PHKT(4,1) =PHKK(4,NC2P)
37186 C PHKT(5,1) =PHKK(5,NC2P)
37187 XMIST =(PHKT(4,1)**2-
37188 * PHKT(3,1)**2-PHKT(2,1)**2-
37190 IF(XMIST.GT.0.D0)THEN
37191 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37194 C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37197 VHKT(1,1) =VHKK(1,NC2P)
37198 VHKT(2,1) =VHKK(2,NC2P)
37199 VHKT(3,1) =VHKK(3,NC2P)
37200 VHKT(4,1) =VHKK(4,NC2P)
37201 WHKT(1,1) =WHKK(1,NC2P)
37202 WHKT(2,1) =WHKK(2,NC2P)
37203 WHKT(3,1) =WHKK(3,NC2P)
37204 WHKT(4,1) =WHKK(4,NC2P)
37205 C Add here IIGLU1 gluons to this chaina
37210 IF(IIGLU1.GE.1)THEN
37212 DO 61 IIG=2,2+IIGLU1-1
37214 IDHKT(IIG) =IDHKK(KKG)
37218 JDAHKT(1,IIG)=3+IIGLU1
37220 PHKT(1,IIG)=PHKK(1,KKG)
37221 PG1=PG1+ PHKT(1,IIG)
37222 PHKT(2,IIG)=PHKK(2,KKG)
37223 PG2=PG2+ PHKT(2,IIG)
37224 PHKT(3,IIG)=PHKK(3,KKG)
37225 PG3=PG3+ PHKT(3,IIG)
37226 PHKT(4,IIG)=PHKK(4,KKG)
37227 PG4=PG4+ PHKT(4,IIG)
37228 PHKT(5,IIG)=PHKK(5,KKG)
37229 VHKT(1,IIG) =VHKK(1,KKG)
37230 VHKT(2,IIG) =VHKK(2,KKG)
37231 VHKT(3,IIG) =VHKK(3,KKG)
37232 VHKT(4,IIG) =VHKK(4,KKG)
37233 WHKT(1,IIG) =WHKK(1,KKG)
37234 WHKT(2,IIG) =WHKK(2,KKG)
37235 WHKT(3,IIG) =WHKK(3,KKG)
37236 WHKT(4,IIG) =WHKK(4,KKG)
37239 IDHKT(2+IIGLU1) =IP21
37240 ISTHKT(2+IIGLU1) =952
37241 JMOHKT(1,2+IIGLU1)=NC1T
37242 JMOHKT(2,2+IIGLU1)=0
37243 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37244 JDAHKT(2,2+IIGLU1)=0
37245 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37246 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37247 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37248 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37249 C PHKT(5,2) =PHKK(5,NC1T)
37250 XMIST =(PHKT(4,2+IIGLU1)**2-
37251 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37252 *PHKT(1,2+IIGLU1)**2)
37253 IF(XMIST.GT.0.D0)THEN
37254 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37255 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37256 *PHKT(1,2+IIGLU1)**2)
37258 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37259 PHKT(5,5+IIGLU1)=0.D0
37261 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
37262 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
37263 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
37264 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
37265 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
37266 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
37267 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
37268 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
37269 IDHKT(3+IIGLU1) =88888
37270 ISTHKT(3+IIGLU1) =95
37271 JMOHKT(1,3+IIGLU1)=1
37272 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37273 JDAHKT(1,3+IIGLU1)=0
37274 JDAHKT(2,3+IIGLU1)=0
37275 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37276 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37277 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37278 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37280 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37281 * -PHKT(3,3+IIGLU1)**2)
37282 IF(XMIST.GT.0.D0)THEN
37284 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37285 * -PHKT(3,3+IIGLU1)**2)
37287 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37288 PHKT(5,5+IIGLU1)=0.D0
37291 C IF(NUMEV.EQ.-324)THEN
37292 C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37294 C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37295 DO 71 IIG=2,2+IIGLU1-1
37296 C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37297 C & JMOHKT(1,IIG),JMOHKT(2,IIG),
37299 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37301 C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37302 C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37303 C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37304 C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37305 C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37306 C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37310 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37311 ELSEIF(IPIP.EQ.2)THEN
37312 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37314 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37318 C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37321 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37322 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37323 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37324 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37325 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37326 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37327 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37328 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37330 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37331 ELSEIF(IPIP.EQ.2)THEN
37332 IDHKT(4+IIGLU1) =ISAQ1
37334 ISTHKT(4+IIGLU1) =951
37335 JMOHKT(1,4+IIGLU1)=NC1P
37336 JMOHKT(2,4+IIGLU1)=0
37337 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37338 JDAHKT(2,4+IIGLU1)=0
37339 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37340 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37341 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37342 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37343 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37344 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37345 XMIST =(PHKT(4,4+IIGLU1)**2-
37346 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37347 *PHKT(1,4+IIGLU1)**2)
37348 IF(XMIST.GT.0.D0)THEN
37349 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37350 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37351 *PHKT(1,4+IIGLU1)**2)
37353 C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37354 PHKT(5,4+IIGLU1)=0.D0
37356 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37357 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37358 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37359 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37360 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37361 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37362 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37363 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37364 IDHKT(5+IIGLU1) =IP22
37365 ISTHKT(5+IIGLU1) =952
37366 JMOHKT(1,5+IIGLU1)=NC1T
37367 JMOHKT(2,5+IIGLU1)=0
37368 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37369 JDAHKT(2,5+IIGLU1)=0
37370 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37371 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37372 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37373 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37374 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37375 XMIST =(PHKT(4,5+IIGLU1)**2-
37376 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37377 *PHKT(1,5+IIGLU1)**2)
37378 IF(XMIST.GT.0.D0)THEN
37379 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37380 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37381 *PHKT(1,5+IIGLU1)**2)
37383 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37384 PHKT(5,5+IIGLU1)=0.D0
37386 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37387 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37388 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37389 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37390 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37391 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37392 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37393 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37394 IDHKT(6+IIGLU1) =88888
37395 ISTHKT(6+IIGLU1) =95
37396 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37397 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37398 JDAHKT(1,6+IIGLU1)=0
37399 JDAHKT(2,6+IIGLU1)=0
37400 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37401 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37402 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37403 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37405 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37406 * -PHKT(3,6+IIGLU1)**2)
37407 IF(XMIST.GT.0.D0)THEN
37409 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37410 * -PHKT(3,6+IIGLU1)**2)
37412 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37413 PHKT(5,5+IIGLU1)=0.D0
37415 C IF(IPIP.GE.2)THEN
37416 C IF(NUMEV.EQ.-324)THEN
37417 C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37418 C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37419 C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37420 C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37421 C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37422 C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37423 C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37424 C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37425 C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37429 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37430 ELSEIF(IPIP.EQ.2)THEN
37431 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37433 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37437 C WRITE(6,*)' MUSQBS1 jump back from chain 6',
37438 C * CHAMAL,PHKT(5,6+IIGLU1)
37441 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37442 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37443 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37444 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37445 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37446 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37447 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37448 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37449 C IDHKT(7) =1000*IPP1+100*ISQ+1
37450 IDHKT(7+IIGLU1) =IP1
37451 ISTHKT(7+IIGLU1) =951
37452 JMOHKT(1,7+IIGLU1)=NC1P
37453 JMOHKT(2,7+IIGLU1)=0
37455 C JDAHKT(1,7+IIGLU1)=9+IIGLU1
37456 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37458 JDAHKT(2,7+IIGLU1)=0
37459 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37460 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37461 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37462 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37463 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
37464 XMIST =(PHKT(4,7+IIGLU1)**2-
37465 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37466 *PHKT(1,7+IIGLU1)**2)
37467 IF(XMIST.GT.0.D0)THEN
37468 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37469 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37470 *PHKT(1,7+IIGLU1)**2)
37472 C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37473 PHKT(5,7+IIGLU1)=0.D0
37475 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
37476 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
37477 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
37478 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
37479 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
37480 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
37481 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
37482 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37483 C Insert here the IIGLU2 gluons
37488 IF(IIGLU2.GE.1)THEN
37490 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37491 KKG=JJG+IIG-7-IIGLU1
37492 IDHKT(IIG) =IDHKK(KKG)
37496 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37498 PHKT(1,IIG)=PHKK(1,KKG)
37499 PG1=PG1+ PHKT(1,IIG)
37500 PHKT(2,IIG)=PHKK(2,KKG)
37501 PG2=PG2+ PHKT(2,IIG)
37502 PHKT(3,IIG)=PHKK(3,KKG)
37503 PG3=PG3+ PHKT(3,IIG)
37504 PHKT(4,IIG)=PHKK(4,KKG)
37505 PG4=PG4+ PHKT(4,IIG)
37506 PHKT(5,IIG)=PHKK(5,KKG)
37507 VHKT(1,IIG) =VHKK(1,KKG)
37508 VHKT(2,IIG) =VHKK(2,KKG)
37509 VHKT(3,IIG) =VHKK(3,KKG)
37510 VHKT(4,IIG) =VHKK(4,KKG)
37511 WHKT(1,IIG) =WHKK(1,KKG)
37512 WHKT(2,IIG) =WHKK(2,KKG)
37513 WHKT(3,IIG) =WHKK(3,KKG)
37514 WHKT(4,IIG) =WHKK(4,KKG)
37518 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+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
37522 ELSEIF(IPIP.EQ.2)THEN
37523 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
37524 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37525 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37526 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37528 ISTHKT(8+IIGLU1+IIGLU2) =952
37529 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37530 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37531 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37532 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37533 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
37534 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37535 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
37536 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37537 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
37538 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37539 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
37540 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37541 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37542 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37543 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37545 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37546 C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37551 C PHKT(5,8) =PHKK(5,NC2T)
37552 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37553 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37554 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37555 IF(XMIST.GT.0.D0)THEN
37556 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37557 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37558 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37560 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37561 PHKT(5,5+IIGLU1)=0.D0
37563 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
37564 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
37565 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
37566 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
37567 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
37568 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
37569 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
37570 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
37571 IDHKT(9+IIGLU1+IIGLU2) =88888
37572 ISTHKT(9+IIGLU1+IIGLU2) =95
37573 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37574 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37575 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37576 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37578 C PHKT(1,9+IIGLU1+IIGLU2)
37579 C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37580 C PHKT(2,9+IIGLU1+IIGLU2)
37581 C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37582 C PHKT(3,9+IIGLU1+IIGLU2)
37583 C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37584 C PHKT(4,9+IIGLU1+IIGLU2)
37585 C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37586 PHKT(1,9+IIGLU1+IIGLU2)
37587 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37588 PHKT(2,9+IIGLU1+IIGLU2)
37589 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37590 PHKT(3,9+IIGLU1+IIGLU2)
37591 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37592 PHKT(4,9+IIGLU1+IIGLU2)
37593 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37596 * =(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)
37599 IF(XMIST.GT.0.D0)THEN
37600 PHKT(5,9+IIGLU1+IIGLU2)
37601 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37602 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37603 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37605 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37606 PHKT(5,5+IIGLU1)=0.D0
37609 C IF(NUMEV.EQ.-324)THEN
37610 C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37611 C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37612 C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37613 C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37614 C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37616 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37618 C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37619 C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37620 C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37621 C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37622 C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37623 C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37624 C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37625 C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37629 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37630 ELSEIF(IPIP.EQ.2)THEN
37631 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37633 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37637 C WRITE(6,*)' MUSQBS1 jump back from chain 9',
37638 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37641 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37642 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37643 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37644 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37645 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37646 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37647 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37648 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37651 IGCOUN=9+IIGLU1+IIGLU2
37655 *$ CREATE MGSQBS2.FOR
37659 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37660 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37661 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37663 C GSQBS-2 diagram (split target diquark)
37665 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37668 PARAMETER ( LINP = 10 ,
37672 PARAMETER (NMXHKK=200000)
37673 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37674 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37675 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37676 * extended event history
37677 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37678 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37680 * Lorentz-parameters of the current interaction
37681 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37682 & UMO,PPCM,EPROJ,PPROJ
37683 * diquark-breaking mechanism
37684 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37687 PARAMETER (NTMHKK= 300)
37688 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37689 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37693 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37696 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37698 C GSQBS-2 diagram (split target diquark)
37701 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37702 C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37704 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37705 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37707 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37708 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37709 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37713 C Put new chains into COMMON /HKKTMP/
37718 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37721 C IF(IPIP.EQ.2)THEN
37722 C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37723 C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37724 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37725 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37730 C determine x-values of NC1T diquark
37731 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37732 XVQP=PHKK(4,NC1P)*2.D0/UMO
37734 C determine x-values of sea quark pair
37740 IF(ICOU.GE.500)THEN
37744 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37749 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37754 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37755 IF (IPIP.EQ.1) THEN
37756 XQMAX = XDIQT/2.0D0
37757 XAQMAX = 2.D0*XVQP/3.0D0
37759 XQMAX = 2.D0*XVQP/3.0D0
37760 XAQMAX = XDIQT/2.0D0
37762 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37764 C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37767 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37770 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37775 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37776 ELSEIF(IPIP.EQ.2)THEN
37777 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37780 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37781 * XDIQT,XVQP,XSQ,XSAQ
37784 C subtract xsq,xsaq from NC1T diquark and NC1P quark
37790 ELSEIF(IPIP.EQ.2)THEN
37795 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37797 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37802 IF(IVTHR.EQ.10)THEN
37805 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37810 XVTHR=XVTHRO/(201-IVTHR)
37813 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37816 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ',
37821 IF(DT_RNDM(V).LT.0.5D0)THEN
37822 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37825 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37829 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37832 C Prepare 4 momenta of new chains and chain ends
37834 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37835 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37838 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37839 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37840 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37842 C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37843 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37850 ELSEIF(IPIP.EQ.2)THEN
37857 C IDHKT(1) =1000*IPP11+100*IPP12+1
37862 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37863 ELSEIF(IPIP.EQ.2)THEN
37864 IDHKT(4+IIGLU1) =ISAQ1
37866 ISTHKT(4+IIGLU1) =961
37867 JMOHKT(1,4+IIGLU1)=NC1P
37868 JMOHKT(2,4+IIGLU1)=0
37869 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37870 JDAHKT(2,4+IIGLU1)=0
37871 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37872 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37873 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37874 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37875 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37876 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37877 XXMIST=(PHKT(4,4+IIGLU1)**2-
37878 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37879 *PHKT(1,4+IIGLU1)**2)
37880 IF(XXMIST.GT.0.D0)THEN
37881 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37883 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37885 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37887 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37888 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37889 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37890 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37891 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37892 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37893 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37894 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37895 IDHKT(5+IIGLU1) =IP22
37896 ISTHKT(5+IIGLU1) =962
37897 JMOHKT(1,5+IIGLU1)=NC1T
37898 JMOHKT(2,5+IIGLU1)=0
37899 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37900 JDAHKT(2,5+IIGLU1)=0
37901 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37902 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37903 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37904 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37905 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37906 XXMIST=(PHKT(4,5+IIGLU1)**2-
37907 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37908 *PHKT(1,5+IIGLU1)**2)
37909 IF(XXMIST.GT.0.D0)THEN
37910 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37912 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37914 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37916 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37917 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37918 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37919 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37920 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37921 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37922 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37923 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37924 IDHKT(6+IIGLU1) =88888
37925 ISTHKT(6+IIGLU1) =96
37926 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37927 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37928 JDAHKT(1,6+IIGLU1)=0
37929 JDAHKT(2,6+IIGLU1)=0
37930 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37931 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37932 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37933 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37935 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37936 * -PHKT(3,6+IIGLU1)**2)
37939 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37940 ELSEIF(IPIP.EQ.2)THEN
37941 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37943 C---------------------------------------------------
37944 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37945 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37946 C we drop chain 6 and give the energy to chain 3
37947 IDHKT(6+IIGLU1)=22888
37949 C WRITE(6,*)' drop chain 6 xgive=1'
37951 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37952 C we drop chain 6 and give the energy to chain 3
37953 C and change KK11 to IDHKT(5)
37954 IDHKT(6+IIGLU1)=22888
37956 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37957 KK11=IDHKT(5+IIGLU1)
37959 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37960 C we drop chain 6 and give the energy to chain 3
37961 C and change KK21 to IDHKT(5+IIGLU1)
37962 C IDHKT(1) =1000*IPP11+100*IPP12+1
37963 IDHKT(6+IIGLU1)=22888
37965 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37966 KK21=IDHKT(5+IIGLU1)
37968 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37969 C we drop chain 6 and give the energy to chain 3
37970 C and change KK22 to IDHKT(5)
37971 C IDHKT(1) =1000*IPP11+100*IPP12+1
37972 IDHKT(6+IIGLU1)=22888
37974 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37975 KK22=IDHKT(5+IIGLU1)
37984 C---------------------------------------------------
37986 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37987 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37988 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37989 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37990 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37991 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37992 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37993 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37994 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37996 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37997 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37998 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37999 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38000 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38001 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38002 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38003 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38004 C IDHKT(1) =1000*IPP11+100*IPP12+1
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
38010 ELSEIF(IPIP.EQ.2)THEN
38011 IDHKT(1) =1000*KK21+100*KK22-3
38012 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
38013 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
38014 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
38019 JDAHKT(1,1)=3+IIGLU1
38021 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
38022 PHKT(1,1) =PHKK(1,NC2P)
38023 *+XGIVE*PHKT(1,4+IIGLU1)
38024 PHKT(2,1) =PHKK(2,NC2P)
38025 *+XGIVE*PHKT(2,4+IIGLU1)
38026 PHKT(3,1) =PHKK(3,NC2P)
38027 *+XGIVE*PHKT(3,4+IIGLU1)
38028 PHKT(4,1) =PHKK(4,NC2P)
38029 *+XGIVE*PHKT(4,4+IIGLU1)
38030 C PHKT(5,1) =PHKK(5,NC2P)
38031 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38033 IF(XXMIST.GT.0.D0)THEN
38034 PHKT(5,1) =SQRT(XXMIST)
38036 WRITE(LOUT,*)'MGSQBS2',XXMIST
38038 PHKT(5,1) =SQRT(XXMIST)
38040 VHKT(1,1) =VHKK(1,NC2P)
38041 VHKT(2,1) =VHKK(2,NC2P)
38042 VHKT(3,1) =VHKK(3,NC2P)
38043 VHKT(4,1) =VHKK(4,NC2P)
38044 WHKT(1,1) =WHKK(1,NC2P)
38045 WHKT(2,1) =WHKK(2,NC2P)
38046 WHKT(3,1) =WHKK(3,NC2P)
38047 WHKT(4,1) =WHKK(4,NC2P)
38048 C Add here IIGLU1 gluons to this chaina
38053 IF(IIGLU1.GE.1)THEN
38055 DO 61 IIG=2,2+IIGLU1-1
38057 IDHKT(IIG) =IDHKK(KKG)
38061 JDAHKT(1,IIG)=3+IIGLU1
38063 PHKT(1,IIG)=PHKK(1,KKG)
38064 PG1=PG1+ PHKT(1,IIG)
38065 PHKT(2,IIG)=PHKK(2,KKG)
38066 PG2=PG2+ PHKT(2,IIG)
38067 PHKT(3,IIG)=PHKK(3,KKG)
38068 PG3=PG3+ PHKT(3,IIG)
38069 PHKT(4,IIG)=PHKK(4,KKG)
38070 PG4=PG4+ PHKT(4,IIG)
38071 PHKT(5,IIG)=PHKK(5,KKG)
38072 VHKT(1,IIG) =VHKK(1,KKG)
38073 VHKT(2,IIG) =VHKK(2,KKG)
38074 VHKT(3,IIG) =VHKK(3,KKG)
38075 VHKT(4,IIG) =VHKK(4,KKG)
38076 WHKT(1,IIG) =WHKK(1,KKG)
38077 WHKT(2,IIG) =WHKK(2,KKG)
38078 WHKT(3,IIG) =WHKK(3,KKG)
38079 WHKT(4,IIG) =WHKK(4,KKG)
38083 IDHKT(2+IIGLU1) =KK11
38084 ISTHKT(2+IIGLU1) =962
38085 JMOHKT(1,2+IIGLU1)=NC1T
38086 JMOHKT(2,2+IIGLU1)=0
38087 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38088 JDAHKT(2,2+IIGLU1)=0
38089 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38090 C * +0.5D0*PHKK(1,NC2T)
38091 *+XGIVE*PHKT(1,5+IIGLU1)
38092 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38093 C *+0.5D0*PHKK(2,NC2T)
38094 *+XGIVE*PHKT(2,5+IIGLU1)
38095 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38096 C *+0.5D0*PHKK(3,NC2T)
38097 *+XGIVE*PHKT(3,5+IIGLU1)
38098 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38099 C *+0.5D0*PHKK(4,NC2T)
38100 *+XGIVE*PHKT(4,5+IIGLU1)
38101 C PHKT(5,2) =PHKK(5,NC1T)
38102 XXMIST=(PHKT(4,2+IIGLU1)**2-
38103 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38104 *PHKT(1,2+IIGLU1)**2)
38105 IF(XXMIST.GT.0.D0)THEN
38106 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38108 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38110 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38112 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
38113 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
38114 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
38115 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
38116 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
38117 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
38118 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
38119 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
38120 IDHKT(3+IIGLU1) =88888
38121 ISTHKT(3+IIGLU1) =96
38122 JMOHKT(1,3+IIGLU1)=1
38123 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38124 JDAHKT(1,3+IIGLU1)=0
38125 JDAHKT(2,3+IIGLU1)=0
38126 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38127 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38128 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38129 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38131 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38132 * -PHKT(3,3+IIGLU1)**2)
38134 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38136 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38137 DO 71 IIG=2,2+IIGLU1-1
38138 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38139 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38141 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38143 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38144 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38145 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38146 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38147 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38148 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38152 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38153 ELSEIF(IPIP.EQ.2)THEN
38154 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38156 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38162 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38163 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38164 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38165 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38166 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38167 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38168 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38169 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38170 C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
38171 IDHKT(7+IIGLU1) =IP1
38172 ISTHKT(7+IIGLU1) =961
38173 JMOHKT(1,7+IIGLU1)=NC1P
38174 JMOHKT(2,7+IIGLU1)=0
38175 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38176 JDAHKT(2,7+IIGLU1)=0
38177 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38178 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38179 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38180 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38181 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
38182 XXMIST=(PHKT(4,7+IIGLU1)**2-
38183 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38184 *PHKT(1,7+IIGLU1)**2)
38185 IF(XXMIST.GT.0.D0)THEN
38186 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38188 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38190 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38192 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
38193 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
38194 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
38195 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
38196 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
38197 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
38198 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
38199 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38200 C IDHKT(7) =1000*IPP1+100*ISQ+1
38201 C Insert here the IIGLU2 gluons
38206 IF(IIGLU2.GE.1)THEN
38208 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38209 KKG=JJG+IIG-7-IIGLU1
38210 IDHKT(IIG) =IDHKK(KKG)
38214 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38216 PHKT(1,IIG)=PHKK(1,KKG)
38217 PG1=PG1+ PHKT(1,IIG)
38218 PHKT(2,IIG)=PHKK(2,KKG)
38219 PG2=PG2+ PHKT(2,IIG)
38220 PHKT(3,IIG)=PHKK(3,KKG)
38221 PG3=PG3+ PHKT(3,IIG)
38222 PHKT(4,IIG)=PHKK(4,KKG)
38223 PG4=PG4+ PHKT(4,IIG)
38224 PHKT(5,IIG)=PHKK(5,KKG)
38225 VHKT(1,IIG) =VHKK(1,KKG)
38226 VHKT(2,IIG) =VHKK(2,KKG)
38227 VHKT(3,IIG) =VHKK(3,KKG)
38228 VHKT(4,IIG) =VHKK(4,KKG)
38229 WHKT(1,IIG) =WHKK(1,KKG)
38230 WHKT(2,IIG) =WHKK(2,KKG)
38231 WHKT(3,IIG) =WHKK(3,KKG)
38232 WHKT(4,IIG) =WHKK(4,KKG)
38236 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
38237 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38238 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38239 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38240 ELSEIF(IPIP.EQ.2)THEN
38242 C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
38243 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
38245 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38246 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38247 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38249 ISTHKT(8+IIGLU1+IIGLU2) =962
38250 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38251 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38252 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38253 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38254 C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38255 C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38256 C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38257 C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38258 PHKT(1,8+IIGLU1+IIGLU2) =
38259 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38260 PHKT(2,8+IIGLU1+IIGLU2) =
38261 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38262 PHKT(3,8+IIGLU1+IIGLU2) =
38263 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38264 PHKT(4,8+IIGLU1+IIGLU2) =
38265 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38266 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38267 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38268 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38270 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38275 C PHKT(5,8) =PHKK(5,NC2T)
38276 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38277 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38278 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38279 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
38280 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
38281 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
38282 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
38283 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
38284 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
38285 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
38286 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
38287 IDHKT(9+IIGLU1+IIGLU2) =88888
38288 ISTHKT(9+IIGLU1+IIGLU2) =96
38289 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38290 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38291 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38292 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38293 PHKT(1,9+IIGLU1+IIGLU2)
38294 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38295 PHKT(2,9+IIGLU1+IIGLU2)
38296 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38297 PHKT(3,9+IIGLU1+IIGLU2)
38298 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38299 PHKT(4,9+IIGLU1+IIGLU2)
38300 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38301 PHKT(5,9+IIGLU1+IIGLU2)
38302 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38303 * PHKT(2,9+IIGLU1+IIGLU2)**2
38304 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38306 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38307 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38308 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38309 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38310 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38311 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38313 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38315 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38316 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38317 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38318 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38319 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38320 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38321 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38322 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38326 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38327 ELSEIF(IPIP.EQ.2)THEN
38328 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38330 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38336 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38337 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38338 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38339 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38340 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38341 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38342 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38343 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38346 IGCOUN=9+IIGLU1+IIGLU2
38350 *$ CREATE MUSQBS1.FOR
38354 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38355 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38356 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38358 C USQBS-1 diagram (split projectile diquark)
38360 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38363 PARAMETER ( LINP = 10 ,
38367 PARAMETER (NMXHKK=200000)
38368 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38369 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38370 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38371 * extended event history
38372 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38373 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38375 * Lorentz-parameters of the current interaction
38376 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38377 & UMO,PPCM,EPROJ,PPROJ
38378 * diquark-breaking mechanism
38379 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38382 PARAMETER (NTMHKK= 300)
38383 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38384 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38387 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38390 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38391 COMMON /EVFLAG/ NUMEV
38393 C USQBS-1 diagram (split projectile diquark)
38395 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38396 C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38398 C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38399 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38401 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38402 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38403 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38405 C Put new chains into COMMON /HKKTMP/
38410 C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38414 C IF(NUMEV.EQ.-324)THEN
38415 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38416 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38417 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38418 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38423 C determine x-values of NC1P diquark
38424 XDIQP=PHKK(4,NC1P)*2.D0/UMO
38425 XVQT=PHKK(4,NC1T)*2.D0/UMO
38427 C determine x-values of sea quark pair
38433 IF(ICOU.GE.500)THEN
38436 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38440 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
38445 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38446 IF (IPIP.EQ.1) THEN
38447 XQMAX = XDIQP/2.0D0
38448 XAQMAX = 2.D0*XVQT/3.0D0
38450 XQMAX = 2.D0*XVQT/3.0D0
38451 XAQMAX = XDIQP/2.0D0
38453 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38455 C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38457 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38460 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38465 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38466 ELSEIF(IPIP.EQ.2)THEN
38467 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38470 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38471 * XDIQP,XVQT,XSQ,XSAQ
38474 C subtract xsq,xsaq from NC1P diquark and NC1T quark
38480 ELSEIF(IPIP.EQ.2)THEN
38485 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38487 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38492 IF(IVTHR.EQ.10)THEN
38495 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38500 XVTHR=XVTHRO/(201-IVTHR)
38503 IF(XVTHR.GT.0.66D0*XDIQP)THEN
38506 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ',
38511 IF(DT_RNDM(V).LT.0.5D0)THEN
38512 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38515 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38519 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38522 C Prepare 4 momenta of new chains and chain ends
38524 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38525 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38527 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38528 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38529 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38535 ELSEIF(IPIP.EQ.2)THEN
38545 JDAHKT(1,1)=3+IIGLU1
38547 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38548 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38549 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38550 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38551 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38552 C PHKT(5,1) =PHKK(5,NC1P)
38553 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38555 IF(XMIST.GE.0.D0)THEN
38556 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38559 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38562 VHKT(1,1) =VHKK(1,NC1P)
38563 VHKT(2,1) =VHKK(2,NC1P)
38564 VHKT(3,1) =VHKK(3,NC1P)
38565 VHKT(4,1) =VHKK(4,NC1P)
38566 WHKT(1,1) =WHKK(1,NC1P)
38567 WHKT(2,1) =WHKK(2,NC1P)
38568 WHKT(3,1) =WHKK(3,NC1P)
38569 WHKT(4,1) =WHKK(4,NC1P)
38570 C Add here IIGLU1 gluons to this chaina
38575 IF(IIGLU1.GE.1)THEN
38577 DO 61 IIG=2,2+IIGLU1-1
38579 IDHKT(IIG) =IDHKK(KKG)
38583 JDAHKT(1,IIG)=3+IIGLU1
38585 PHKT(1,IIG)=PHKK(1,KKG)
38586 PG1=PG1+ PHKT(1,IIG)
38587 PHKT(2,IIG)=PHKK(2,KKG)
38588 PG2=PG2+ PHKT(2,IIG)
38589 PHKT(3,IIG)=PHKK(3,KKG)
38590 PG3=PG3+ PHKT(3,IIG)
38591 PHKT(4,IIG)=PHKK(4,KKG)
38592 PG4=PG4+ PHKT(4,IIG)
38593 PHKT(5,IIG)=PHKK(5,KKG)
38594 VHKT(1,IIG) =VHKK(1,KKG)
38595 VHKT(2,IIG) =VHKK(2,KKG)
38596 VHKT(3,IIG) =VHKK(3,KKG)
38597 VHKT(4,IIG) =VHKK(4,KKG)
38598 WHKT(1,IIG) =WHKK(1,KKG)
38599 WHKT(2,IIG) =WHKK(2,KKG)
38600 WHKT(3,IIG) =WHKK(3,KKG)
38601 WHKT(4,IIG) =WHKK(4,KKG)
38604 IDHKT(2+IIGLU1) =IPP2
38605 ISTHKT(2+IIGLU1) =932
38606 JMOHKT(1,2+IIGLU1)=NC2T
38607 JMOHKT(2,2+IIGLU1)=0
38608 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38609 JDAHKT(2,2+IIGLU1)=0
38610 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38611 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38612 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38613 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38614 C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
38615 XMIST=(PHKT(4,2+IIGLU1)**2-
38616 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38617 *PHKT(1,2+IIGLU1)**2)
38618 IF(XMIST.GT.0.D0)THEN
38619 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38620 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38621 *PHKT(1,2+IIGLU1)**2)
38623 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38624 PHKT(5,2+IIGLU1)=0.D0
38626 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38627 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38628 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38629 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38630 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38631 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38632 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38633 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38634 IDHKT(3+IIGLU1) =88888
38635 ISTHKT(3+IIGLU1) =94
38636 JMOHKT(1,3+IIGLU1)=1
38637 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38638 JDAHKT(1,3+IIGLU1)=0
38639 JDAHKT(2,3+IIGLU1)=0
38640 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38641 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38642 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38643 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38645 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38646 * -PHKT(3,3+IIGLU1)**2)
38647 IF(XMIST.GE.0.D0)THEN
38649 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38650 * -PHKT(3,3+IIGLU1)**2)
38652 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38656 C IF(NUMEV.EQ.-324)THEN
38657 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38658 * JMOHKT(2,1),JDAHKT(1,1),
38659 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38660 DO 71 IIG=2,2+IIGLU1-1
38661 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38662 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38664 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38666 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38667 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38668 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38669 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38670 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38671 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38675 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38676 ELSEIF(IPIP.EQ.2)THEN
38677 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38679 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38683 C WRITE(6,*)' MUSQBS1 jump back from chain 3'
38686 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38687 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38688 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38689 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38690 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38691 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38692 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38693 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38694 IDHKT(4+IIGLU1) =IP12
38695 ISTHKT(4+IIGLU1) =931
38696 JMOHKT(1,4+IIGLU1)=NC1P
38697 JMOHKT(2,4+IIGLU1)=0
38698 JDAHKT(1,4+IIGLU1)=6+IIGLU1
38699 JDAHKT(2,4+IIGLU1)=0
38700 C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38701 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38702 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38703 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38704 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38705 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
38706 XMIST =(PHKT(4,4+IIGLU1)**2-
38707 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38708 *PHKT(1,4+IIGLU1)**2)
38709 IF(XMIST.GT.0.D0)THEN
38710 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
38711 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38712 *PHKT(1,4+IIGLU1)**2)
38714 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38715 PHKT(5,4+IIGLU1)=0.D0
38717 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
38718 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
38719 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
38720 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
38721 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
38722 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
38723 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
38724 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
38726 IDHKT(5+IIGLU1) =-(ISAQ1-6)
38727 ELSEIF(IPIP.EQ.2)THEN
38728 IDHKT(5+IIGLU1) =ISAQ1
38730 ISTHKT(5+IIGLU1) =932
38731 JMOHKT(1,5+IIGLU1)=NC1T
38732 JMOHKT(2,5+IIGLU1)=0
38733 JDAHKT(1,5+IIGLU1)=6+IIGLU1
38734 JDAHKT(2,5+IIGLU1)=0
38735 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38736 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38737 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38738 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38739 C IF( PHKT(4,5).EQ.0.D0)THEN
38744 C PHKT(5,5) =PHKK(5,NC1T)
38745 XMIST=(PHKT(4,5+IIGLU1)**2-
38746 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38747 *PHKT(1,5+IIGLU1)**2)
38748 IF(XMIST.GT.0.D0)THEN
38749 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
38750 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38751 *PHKT(1,5+IIGLU1)**2)
38753 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38754 PHKT(5,5+IIGLU1)=0.D0
38756 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
38757 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
38758 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
38759 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
38760 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
38761 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
38762 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
38763 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
38764 IDHKT(6+IIGLU1) =88888
38765 ISTHKT(6+IIGLU1) =94
38766 JMOHKT(1,6+IIGLU1)=4+IIGLU1
38767 JMOHKT(2,6+IIGLU1)=5+IIGLU1
38768 JDAHKT(1,6+IIGLU1)=0
38769 JDAHKT(2,6+IIGLU1)=0
38770 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38771 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38772 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38773 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38775 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38776 * -PHKT(3,6+IIGLU1)**2)
38777 IF(XMIST.GE.0.D0)THEN
38779 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38780 * -PHKT(3,6+IIGLU1)**2)
38782 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38785 C IF(IPIP.EQ.3)THEN
38788 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38789 ELSEIF(IPIP.EQ.2)THEN
38790 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38792 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38796 C WRITE(6,*)' MGSQBS1 jump back from chain 6',
38797 C * CHAMAL,PHKT(5,6+IIGLU1)
38801 C IF(NUMEV.EQ.-324)THEN
38802 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38803 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38804 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38805 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38806 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38807 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38808 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38809 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38810 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38812 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38813 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38814 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38815 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38816 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38817 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38818 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38819 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38821 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+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 ELSEIF(IPIP.EQ.2)THEN
38826 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38827 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38828 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38829 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38830 C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38832 ISTHKT(7+IIGLU1) =931
38833 JMOHKT(1,7+IIGLU1)=NC2P
38834 JMOHKT(2,7+IIGLU1)=0
38835 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38836 JDAHKT(2,7+IIGLU1)=0
38837 C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38838 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38839 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38840 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38841 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38842 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38843 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38844 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38846 C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38851 C PHKT(5,7) =PHKK(5,NC2P)
38852 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38853 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38854 *PHKT(1,7+IIGLU1)**2)
38855 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38856 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38857 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38858 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38859 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38860 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38861 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38862 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38863 C Insert here the IIGLU2 gluons
38868 IF(IIGLU2.GE.1)THEN
38870 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38871 KKG=JJG+IIG-7-IIGLU1
38872 IDHKT(IIG) =IDHKK(KKG)
38876 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38878 PHKT(1,IIG)=PHKK(1,KKG)
38879 PG1=PG1+ PHKT(1,IIG)
38880 PHKT(2,IIG)=PHKK(2,KKG)
38881 PG2=PG2+ PHKT(2,IIG)
38882 PHKT(3,IIG)=PHKK(3,KKG)
38883 PG3=PG3+ PHKT(3,IIG)
38884 PHKT(4,IIG)=PHKK(4,KKG)
38885 PG4=PG4+ PHKT(4,IIG)
38886 PHKT(5,IIG)=PHKK(5,KKG)
38887 VHKT(1,IIG) =VHKK(1,KKG)
38888 VHKT(2,IIG) =VHKK(2,KKG)
38889 VHKT(3,IIG) =VHKK(3,KKG)
38890 VHKT(4,IIG) =VHKK(4,KKG)
38891 WHKT(1,IIG) =WHKK(1,KKG)
38892 WHKT(2,IIG) =WHKK(2,KKG)
38893 WHKT(3,IIG) =WHKK(3,KKG)
38894 WHKT(4,IIG) =WHKK(4,KKG)
38897 IDHKT(8+IIGLU1+IIGLU2) =IP2
38898 ISTHKT(8+IIGLU1+IIGLU2) =932
38899 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38900 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38901 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38902 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38903 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38904 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38905 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38906 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38907 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38908 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38909 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38910 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38911 IF(XMIST.GT.0.D0)THEN
38912 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38913 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38914 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38916 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38917 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38919 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38920 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38921 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38922 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38923 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38924 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38925 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38926 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38927 IDHKT(9+IIGLU1+IIGLU2) =88888
38928 ISTHKT(9+IIGLU1+IIGLU2) =94
38929 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38930 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38931 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38932 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38933 PHKT(1,9+IIGLU1+IIGLU2)
38934 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38935 PHKT(2,9+IIGLU1+IIGLU2)
38936 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38937 PHKT(3,9+IIGLU1+IIGLU2)
38938 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38939 PHKT(4,9+IIGLU1+IIGLU2)
38940 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38942 *=(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)
38945 IF(XMIST.GE.0.D0)THEN
38946 PHKT(5,9+IIGLU1+IIGLU2)
38947 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38948 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38949 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38951 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38955 C IF(NUMEV.EQ.-324)THEN
38956 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38957 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38958 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38959 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38960 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38961 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38963 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38965 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38966 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38967 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38968 *JDAHKT(1,8+IIGLU1+IIGLU2),
38969 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38970 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38971 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38972 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38973 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38977 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38978 ELSEIF(IPIP.EQ.2)THEN
38979 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38981 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38985 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38986 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38989 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38990 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38991 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38992 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38993 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38994 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38995 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38996 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38999 IGCOUN=9+IIGLU1+IIGLU2
39003 *$ CREATE MGSQBS1.FOR
39006 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39007 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39008 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
39010 C GSQBS-1 diagram (split projectile diquark)
39012 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39015 PARAMETER ( LINP = 10 ,
39019 PARAMETER (NMXHKK=200000)
39020 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39021 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39022 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39023 * extended event history
39024 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39025 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39027 * Lorentz-parameters of the current interaction
39028 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
39029 & UMO,PPCM,EPROJ,PPROJ
39030 * diquark-breaking mechanism
39031 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39034 PARAMETER (NTMHKK= 300)
39035 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39036 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39039 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39042 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39044 C GSQBS-1 diagram (split projectile diquark)
39047 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39048 C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39050 C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39051 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39053 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39054 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39055 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39057 C Put new chains into COMMON /HKKTMP/
39062 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39064 NNNC1=IDHKK(NC1)/1000
39065 MMMC1=IDHKK(NC1)-NNNC1*1000
39067 NNNC2=IDHKK(NC2)/1000
39068 MMMC2=IDHKK(NC2)-NNNC2*1000
39072 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39073 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39074 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39075 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39080 C determine x-values of NC1P diquark
39081 XDIQP=PHKK(4,NC1P)*2.D0/UMO
39082 XVQT=PHKK(4,NC1T)*2.D0/UMO
39084 C determine x-values of sea quark pair
39090 IF(ICOU.GE.500)THEN
39093 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39097 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
39102 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39103 IF (IPIP.EQ.1) THEN
39104 XQMAX = XDIQP/2.0D0
39105 XAQMAX = 2.D0*XVQT/3.0D0
39107 XQMAX = 2.D0*XVQT/3.0D0
39108 XAQMAX = XDIQP/2.0D0
39110 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39112 C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39115 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39118 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39123 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39124 ELSEIF(IPIP.EQ.2)THEN
39125 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39128 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39129 * XDIQP,XVQT,XSQ,XSAQ
39132 C subtract xsq,xsaq from NC1P diquark and NC1T quark
39138 C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39141 ELSEIF(IPIP.EQ.2)THEN
39146 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39148 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39153 IF(IVTHR.EQ.10)THEN
39156 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39161 XVTHR=XVTHRO/(201-IVTHR)
39164 IF(XVTHR.GT.0.66D0*XDIQP)THEN
39168 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ',
39173 IF(DT_RNDM(V).LT.0.5D0)THEN
39174 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39177 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39181 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39182 * XVTHR,XDIQP,XVPQI,XVPQII
39185 C Prepare 4 momenta of new chains and chain ends
39187 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39188 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39190 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39191 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39192 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39198 ELSEIF(IPIP.EQ.2)THEN
39205 C IDHKT(2) =1000*IPP21+100*IPP22+1
39209 IDHKT(4+IIGLU1) =IP12
39210 ISTHKT(4+IIGLU1) =921
39211 JMOHKT(1,4+IIGLU1)=NC1P
39212 JMOHKT(2,4+IIGLU1)=0
39213 JDAHKT(1,4+IIGLU1)=6+IIGLU1
39214 JDAHKT(2,4+IIGLU1)=0
39216 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39217 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39219 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39220 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39221 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39222 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39223 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
39224 XXMIST=(PHKT(4,4+IIGLU1)**2-
39225 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39226 * PHKT(1,4+IIGLU1)**2)
39227 IF(XXMIST.GT.0.D0)THEN
39228 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39230 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39232 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39234 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
39235 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
39236 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
39237 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
39238 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
39239 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
39240 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
39241 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
39243 IDHKT(5+IIGLU1) =-(ISAQ1-6)
39244 ELSEIF(IPIP.EQ.2)THEN
39245 IDHKT(5+IIGLU1) =ISAQ1
39247 ISTHKT(5+IIGLU1) =922
39248 JMOHKT(1,5+IIGLU1)=NC1T
39249 JMOHKT(2,5+IIGLU1)=0
39250 JDAHKT(1,5+IIGLU1)=6+IIGLU1
39251 JDAHKT(2,5+IIGLU1)=0
39253 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
39254 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39256 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39257 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39258 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39259 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39260 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
39261 XMIST=(PHKT(4,5+IIGLU1)**2-
39262 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39263 *PHKT(1,5+IIGLU1)**2)
39264 IF(XMIST.GT.0.D0)THEN
39265 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
39266 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39267 *PHKT(1,5+IIGLU1)**2)
39269 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39270 PHKT(5,5+IIGLU1)=0.D0
39272 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
39273 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
39274 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
39275 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
39276 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
39277 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
39278 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
39279 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
39280 IDHKT(6+IIGLU1) =88888
39281 C IDHKT(6) =1000*NNNC1+MMMC1
39282 ISTHKT(6+IIGLU1) =93
39284 JMOHKT(1,6+IIGLU1)=4+IIGLU1
39285 JMOHKT(2,6+IIGLU1)=5+IIGLU1
39286 JDAHKT(1,6+IIGLU1)=0
39287 JDAHKT(2,6+IIGLU1)=0
39288 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39289 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39290 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39291 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39293 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39294 * -PHKT(3,6+IIGLU1)**2)
39297 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39298 ELSEIF(IPIP.EQ.2)THEN
39299 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39301 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39302 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39303 C we drop chain 6 and give the energy to chain 3
39304 IDHKT(6+IIGLU1)=33888
39306 C WRITE(6,*)' drop chain 6 xgive=1'
39308 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39309 C we drop chain 6 and give the energy to chain 3
39310 C and change KK11 to IDHKT(4)
39311 IDHKT(6+IIGLU1)=33888
39313 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39314 KK11=IDHKT(4+IIGLU1)
39316 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39317 C we drop chain 6 and give the energy to chain 3
39318 C and change KK21 to IDHKT(4)
39319 C IDHKT(2) =1000*IPP21+100*IPP22+1
39320 IDHKT(6+IIGLU1)=33888
39322 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39323 KK21=IDHKT(4+IIGLU1)
39325 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39326 C we drop chain 6 and give the energy to chain 3
39327 C and change KK22 to IDHKT(4)
39328 C IDHKT(2) =1000*IPP21+100*IPP22+1
39329 IDHKT(6+IIGLU1)=33888
39331 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39332 KK22=IDHKT(4+IIGLU1)
39338 C WRITE(6,*)' MGSQBS1 jump back from chain 6'
39343 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39344 * JMOHKT(1,4+IIGLU1),
39345 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39346 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39347 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39348 * JMOHKT(1,5+IIGLU1),
39349 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39350 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39351 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39352 * JMOHKT(1,6+IIGLU1),
39353 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39354 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39356 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
39357 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
39358 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
39359 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
39360 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
39361 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
39362 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
39363 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
39369 JDAHKT(1,1)=3+IIGLU1
39371 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39372 C * +0.5D0*PHKK(1,NC2P)
39373 *+XGIVE*PHKT(1,4+IIGLU1)
39374 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39375 C * +0.5D0*PHKK(2,NC2P)
39376 *+XGIVE*PHKT(2,4+IIGLU1)
39377 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39378 C * +0.5D0*PHKK(3,NC2P)
39379 *+XGIVE*PHKT(3,4+IIGLU1)
39380 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39381 C * +0.5D0*PHKK(4,NC2P)
39382 *+XGIVE*PHKT(4,4+IIGLU1)
39383 C PHKT(5,1) =PHKK(5,NC1P)
39384 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39386 IF(XMIST.GE.0.D0)THEN
39387 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39390 C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39393 VHKT(1,1) =VHKK(1,NC1P)
39394 VHKT(2,1) =VHKK(2,NC1P)
39395 VHKT(3,1) =VHKK(3,NC1P)
39396 VHKT(4,1) =VHKK(4,NC1P)
39397 WHKT(1,1) =WHKK(1,NC1P)
39398 WHKT(2,1) =WHKK(2,NC1P)
39399 WHKT(3,1) =WHKK(3,NC1P)
39400 WHKT(4,1) =WHKK(4,NC1P)
39401 C Add here IIGLU1 gluons to this chaina
39406 IF(IIGLU1.GE.1)THEN
39408 DO 61 IIG=2,2+IIGLU1-1
39410 IDHKT(IIG) =IDHKK(KKG)
39414 JDAHKT(1,IIG)=3+IIGLU1
39416 PHKT(1,IIG)=PHKK(1,KKG)
39417 PG1=PG1+ PHKT(1,IIG)
39418 PHKT(2,IIG)=PHKK(2,KKG)
39419 PG2=PG2+ PHKT(2,IIG)
39420 PHKT(3,IIG)=PHKK(3,KKG)
39421 PG3=PG3+ PHKT(3,IIG)
39422 PHKT(4,IIG)=PHKK(4,KKG)
39423 PG4=PG4+ PHKT(4,IIG)
39424 PHKT(5,IIG)=PHKK(5,KKG)
39425 VHKT(1,IIG) =VHKK(1,KKG)
39426 VHKT(2,IIG) =VHKK(2,KKG)
39427 VHKT(3,IIG) =VHKK(3,KKG)
39428 VHKT(4,IIG) =VHKK(4,KKG)
39429 WHKT(1,IIG) =WHKK(1,KKG)
39430 WHKT(2,IIG) =WHKK(2,KKG)
39431 WHKT(3,IIG) =WHKK(3,KKG)
39432 WHKT(4,IIG) =WHKK(4,KKG)
39435 C IDHKT(2) =1000*IPP21+100*IPP22+1
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
39441 ELSEIF(IPIP.EQ.2)THEN
39442 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
39443 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39444 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39445 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39447 ISTHKT(2+IIGLU1) =922
39448 JMOHKT(1,2+IIGLU1)=NC2T
39449 JMOHKT(2,2+IIGLU1)=0
39450 JDAHKT(1,2+IIGLU1)=3+IIGLU1
39451 JDAHKT(2,2+IIGLU1)=0
39452 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
39453 *+XGIVE*PHKT(1,5+IIGLU1)
39454 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
39455 *+XGIVE*PHKT(2,5+IIGLU1)
39456 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
39457 *+XGIVE*PHKT(3,5+IIGLU1)
39458 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
39459 *+XGIVE*PHKT(4,5+IIGLU1)
39460 C PHKT(5,2) =PHKK(5,NC2T)
39461 XMIST=(PHKT(4,2+IIGLU1)**2-
39462 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39463 *PHKT(1,2+IIGLU1)**2)
39464 IF(XMIST.GT.0.D0)THEN
39465 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
39466 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39467 *PHKT(1,2+IIGLU1)**2)
39469 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39470 PHKT(5,2+IIGLU1)=0.D0
39472 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
39473 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
39474 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
39475 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
39476 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
39477 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
39478 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
39479 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
39480 IDHKT(3+IIGLU1) =88888
39481 C IDHKT(3) =1000*NNNC1+MMMC1+10
39482 ISTHKT(3+IIGLU1) =93
39484 JMOHKT(1,3+IIGLU1)=1
39485 JMOHKT(2,3+IIGLU1)=2+IIGLU1
39486 JDAHKT(1,3+IIGLU1)=0
39487 JDAHKT(2,3+IIGLU1)=0
39488 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39489 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39490 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39491 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39493 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39494 * -PHKT(3,3+IIGLU1)**2)
39496 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39498 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39499 DO 71 IIG=2,2+IIGLU1-1
39500 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39501 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39503 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39505 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39506 & IDHKT(2),JMOHKT(1,2+IIGLU1),
39507 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39508 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39509 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39510 * JMOHKT(1,3+IIGLU1),
39511 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39512 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39516 C IF(IPIP.EQ.1)THEN
39517 C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39518 C ELSEIF(IPIP.EQ.2)THEN
39519 C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39522 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39523 ELSEIF(IPIP.EQ.2)THEN
39524 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39527 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39531 C WRITE(6,*)' MGSQBS1 jump back from chain 3'
39534 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
39535 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
39536 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
39537 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
39538 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
39539 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
39540 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
39541 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
39543 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+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 ELSEIF(IPIP.EQ.2)THEN
39548 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
39549 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39550 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39551 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39552 C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39554 ISTHKT(7+IIGLU1) =921
39555 JMOHKT(1,7+IIGLU1)=NC2P
39556 JMOHKT(2,7+IIGLU1)=0
39557 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39558 JDAHKT(2,7+IIGLU1)=0
39559 C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39560 C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39561 C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39562 C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39564 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39565 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39567 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39568 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39569 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39570 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39571 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39572 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39573 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39575 C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39580 C PHKT(5,7) =PHKK(5,NC2P)
39581 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
39582 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39583 *PHKT(1,7+IIGLU1)**2)
39584 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
39585 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
39586 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
39587 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
39588 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
39589 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
39590 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
39591 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
39592 C Insert here the IIGLU2 gluons
39597 IF(IIGLU2.GE.1)THEN
39599 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39600 KKG=JJG+IIG-7-IIGLU1
39601 IDHKT(IIG) =IDHKK(KKG)
39605 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39607 PHKT(1,IIG)=PHKK(1,KKG)
39608 PG1=PG1+ PHKT(1,IIG)
39609 PHKT(2,IIG)=PHKK(2,KKG)
39610 PG2=PG2+ PHKT(2,IIG)
39611 PHKT(3,IIG)=PHKK(3,KKG)
39612 PG3=PG3+ PHKT(3,IIG)
39613 PHKT(4,IIG)=PHKK(4,KKG)
39614 PG4=PG4+ PHKT(4,IIG)
39615 PHKT(5,IIG)=PHKK(5,KKG)
39616 VHKT(1,IIG) =VHKK(1,KKG)
39617 VHKT(2,IIG) =VHKK(2,KKG)
39618 VHKT(3,IIG) =VHKK(3,KKG)
39619 VHKT(4,IIG) =VHKK(4,KKG)
39620 WHKT(1,IIG) =WHKK(1,KKG)
39621 WHKT(2,IIG) =WHKK(2,KKG)
39622 WHKT(3,IIG) =WHKK(3,KKG)
39623 WHKT(4,IIG) =WHKK(4,KKG)
39626 IDHKT(8+IIGLU1+IIGLU2) =IP2
39627 ISTHKT(8+IIGLU1+IIGLU2) =922
39628 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39629 JMOHKT(2,8+IIGLU1+IIGLU2)=0
39630 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39631 JDAHKT(2,8+IIGLU1+IIGLU2)=0
39633 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39634 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39636 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39637 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39638 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39639 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39640 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
39641 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39642 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39643 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39644 IF(XMIST.GT.0.D0)THEN
39645 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39646 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39647 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39649 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39650 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39652 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
39653 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
39654 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
39655 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
39656 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
39657 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
39658 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
39659 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
39660 IDHKT(9+IIGLU1+IIGLU2) =88888
39661 C IDHKT(9) =1000*NNNC2+MMMC2+10
39662 ISTHKT(9+IIGLU1+IIGLU2) =93
39664 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39665 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39666 JDAHKT(1,9+IIGLU1+IIGLU2)=0
39667 JDAHKT(2,9+IIGLU1+IIGLU2)=0
39668 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
39669 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39670 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
39671 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39672 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
39673 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39674 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
39675 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39676 PHKT(5,9+IIGLU1+IIGLU2)
39677 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39678 * PHKT(2,9+IIGLU1+IIGLU2)**2
39679 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
39681 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39682 * JMOHKT(1,7+IIGLU1),
39683 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39684 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39685 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39686 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39687 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39689 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39691 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39692 * IDHKT(8+IIGLU1+IIGLU2),
39693 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39694 * JDAHKT(1,8+IIGLU1+IIGLU2),
39695 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39696 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39697 * IDHKT(9+IIGLU1+IIGLU2),
39698 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39699 * JDAHKT(1,9+IIGLU1+IIGLU2),
39700 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39704 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39705 ELSEIF(IPIP.EQ.2)THEN
39706 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39708 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39712 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
39713 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39716 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
39717 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
39718 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
39719 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
39720 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
39721 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
39722 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
39723 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
39725 IGCOUN=9+IIGLU1+IIGLU2
39730 *$ CREATE HKKHKT.FOR
39733 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39735 SUBROUTINE HKKHKT(I,J)
39736 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39740 PARAMETER (NMXHKK=200000)
39741 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39742 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39743 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39744 * extended event history
39745 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39746 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39749 PARAMETER (NTMHKK= 300)
39750 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39751 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39754 ISTHKK(I) =ISTHKT(J)
39756 C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39757 IF(IDHKK(I).EQ.88888)THEN
39760 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39761 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39763 JMOHKK(1,I)=JMOHKT(1,J)
39764 JMOHKK(2,I)=JMOHKT(2,J)
39766 JDAHKK(1,I)=JDAHKT(1,J)
39767 JDAHKK(2,I)=JDAHKT(2,J)
39768 C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39770 C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39773 IF(JDAHKT(1,J).GT.0)THEN
39774 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39776 PHKK(1,I) =PHKT(1,J)
39777 PHKK(2,I) =PHKT(2,J)
39778 PHKK(3,I) =PHKT(3,J)
39779 PHKK(4,I) =PHKT(4,J)
39780 PHKK(5,I) =PHKT(5,J)
39781 VHKK(1,I) =VHKT(1,J)
39782 VHKK(2,I) =VHKT(2,J)
39783 VHKK(3,I) =VHKT(3,J)
39784 VHKK(4,I) =VHKT(4,J)
39785 WHKK(1,I) =WHKT(1,J)
39786 WHKK(2,I) =WHKT(2,J)
39787 WHKK(3,I) =WHKT(3,J)
39788 WHKK(4,I) =WHKT(4,J)
39792 *$ CREATE DT_DBREAK.FOR
39795 *===dbreak=============================================================*
39797 SUBROUTINE DT_DBREAK(MODE)
39799 ************************************************************************
39800 * This is the steering subroutine for the different diquark breaking *
39803 * MODE = 1 breaking of projectile diquark in qq-q chain using *
39804 * a sea quark (q-qq chain) of the same projectile *
39805 * = 2 breaking of target diquark in q-qq chain using *
39806 * a sea quark (qq-q chain) of the same target *
39807 * = 3 breaking of projectile diquark in qq-q chain using *
39808 * a sea quark (q-aq chain) of the same projectile *
39809 * = 4 breaking of target diquark in q-qq chain using *
39810 * a sea quark (aq-q chain) of the same target *
39811 * = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
39812 * a sea anti-quark (aq-aqaq chain) of the same projectile *
39813 * = 6 breaking of target anti-diquark in aq-aqaq chain using *
39814 * a sea anti-quark (aqaq-aq chain) of the same target *
39815 * = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
39816 * a sea anti-quark (aq-q chain) of the same projectile *
39817 * = 8 breaking of target anti-diquark in aq-aqaq chain using *
39818 * a sea anti-quark (q-aq chain) of the same target *
39820 * Original version by J. Ranft. *
39821 * This version dated 17.5.00 is written by S. Roesler. *
39822 ************************************************************************
39824 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39826 PARAMETER ( LINP = 10 ,
39831 PARAMETER (NMXHKK=200000)
39832 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39833 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39834 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39835 * extended event history
39836 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39837 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39839 * flags for input different options
39840 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39841 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39842 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39843 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39844 PARAMETER (MAXCHN=10000)
39845 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39846 * diquark-breaking mechanism
39847 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39848 * flags for particle decays
39849 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39850 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39851 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39854 * chain identifiers
39855 * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
39856 * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39857 DIMENSION IDCHN1(8),IDCHN2(8)
39858 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39859 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39861 * parton identifiers
39862 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39863 * +-51/52 = unitarity-sea, +-61/62 = gluons )
39864 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39865 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39866 & 31, 31, 31, 31, 31, 31, 31, 31,
39867 & 41, 41, 41, 41, 51, 51, 51, 51/
39868 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39869 & 32, 32, 32, 32, 32, 32, 32, 32,
39870 & 42, 42, 42, 42, 52, 52, 52, 52/
39871 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39872 & 51, 31, 41, 41, 31, 31, 31, 31,
39873 & 0, 41, 51, 51, 51, 51, 51, 51/
39874 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39875 & 32, 52, 42, 42, 32, 32, 32, 32,
39876 & 42, 0, 52, 52, 52, 52, 52, 52/
39878 IF (NCHAIN.LE.0) RETURN
39881 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39882 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39883 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39885 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39886 & (IS1P.EQ.ISP1P(MODE,3)))
39888 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39889 & (IS1T.EQ.ISP1T(MODE,3)))
39893 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39894 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39895 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39897 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39898 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
39900 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39901 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
39903 * find mother nucleons of the diquark to be splitted and of the
39904 * sea-quark and reject this combination if it is not the same
39905 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39906 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39911 IDXMO1 = JMOHKK(IANCES,IDX1)
39913 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39914 & (JMOHKK(2,IDXMO1).NE.0)) THEN
39919 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39920 IDXMO1 = JMOHKK(IANC,IDXMO1)
39923 IDXMO2 = JMOHKK(IANCES,IDX2)
39925 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39926 & (JMOHKK(2,IDXMO2).NE.0)) THEN
39931 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39932 IDXMO2 = JMOHKK(IANC,IDXMO2)
39935 IF (IDXMO1.NE.IDXMO2) GOTO 2
39936 * quark content of projectile parton
39937 IP1 = IDHKK(JMOHKK(1,IDX1))
39939 IP12 = (IP1-1000*IP11)/100
39940 IP2 = IDHKK(JMOHKK(2,IDX1))
39942 IP22 = (IP2-1000*IP21)/100
39943 * quark content of target parton
39944 IT1 = IDHKK(JMOHKK(1,IDX2))
39946 IT12 = (IT1-1000*IT11)/100
39947 IT2 = IDHKK(JMOHKK(2,IDX2))
39949 IT22 = (IT2-1000*IT21)/100
39950 * split diquark and form new chains
39951 IF (MODE.EQ.1) THEN
39952 IF (IT1.EQ.4) GOTO 2
39953 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39954 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39955 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39956 ELSEIF (MODE.EQ.2) THEN
39957 IF (IT2.EQ.4) GOTO 2
39958 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39959 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39960 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39961 ELSEIF (MODE.EQ.3) THEN
39962 IF (IT1.EQ.4) GOTO 2
39963 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39964 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39965 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39966 ELSEIF (MODE.EQ.4) THEN
39967 IF (IT2.EQ.4) GOTO 2
39968 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39969 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39970 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39971 ELSEIF (MODE.EQ.5) THEN
39972 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39973 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39974 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39975 ELSEIF (MODE.EQ.6) THEN
39976 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39977 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39978 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39979 ELSEIF (MODE.EQ.7) THEN
39980 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39981 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39982 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39983 ELSEIF (MODE.EQ.8) THEN
39984 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39985 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39986 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
39988 IF (IREJ.GE.1) THEN
39989 if ((ipq.lt.0).or.(ipq.ge.4))
39990 & write(LOUT,*) 'ipq !!!',ipq,mode
39991 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39992 * accept or reject new chains corresponding to PDBSEA
39994 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
39995 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
39996 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
39997 ELSEIF (IPQ.EQ.3) THEN
39998 ACC = DBRKA(3,MODE)
39999 REJ = DBRKR(3,MODE)
40001 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
40004 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
40005 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
40008 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
40011 * new chains have been accepted and are now copied into HKKEVT
40012 IF (IACC.EQ.1) THEN
40014 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
40015 & PHKK(3,IDX1),PHKK(4,IDX1),
40017 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
40018 & PHKK(3,IDX2),PHKK(4,IDX2),
40021 IDHKK(IDX1) = 99888
40022 IDHKK(IDX2) = 99888
40027 CALL HKKHKT(NHKK,K)
40028 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
40033 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
40038 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
40040 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40052 *$ CREATE DT_CQPAIR.FOR
40055 *===cqpair=============================================================*
40057 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40059 ************************************************************************
40060 * This subroutine Creates a Quark-antiquark PAIR from the sea. *
40062 * XQMAX maxium energy fraction of quark (input) *
40063 * XAQMAX maxium energy fraction of antiquark (input) *
40064 * XQ energy fraction of quark (output) *
40065 * XAQ energy fraction of antiquark (output) *
40066 * IFLV quark flavour (- antiquark flavor) (output) *
40068 * This version dated 14.5.00 is written by S. Roesler. *
40069 ************************************************************************
40071 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40073 PARAMETER ( LINP = 10 ,
40077 * Lorentz-parameters of the current interaction
40078 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40079 & UMO,PPCM,EPROJ,PPROJ
40086 * sample quark flavour
40088 * set seasq here (the one from DTCHAI should be used in the future)
40090 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40092 * sample energy fractions of sea pair
40093 * we first sample the energy fraction of a gluon and then split the gluon
40095 * maximum energy fraction of the gluon forced via input
40096 XGMAXI = XQMAX+XAQMAX
40097 * minimum energy fraction of the gluon
40098 XTHR1 = 4.0D0 /UMO**2
40099 XTHR2 = 0.54D0/UMO**1.5D0
40100 XGMIN = MAX(XTHR1,XTHR2)
40101 * maximum energy fraction of the gluon
40103 XGMAX = MIN(XGMAXI,XGMAX)
40104 IF (XGMIN.GE.XGMAX) THEN
40109 * sample energy fraction of the gluon
40113 IF (NLOOP.GE.50) THEN
40117 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40118 EGLUON = XGLUON*UMO/2.0D0
40120 * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40121 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40124 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40126 IF (RQ.LT.0.5D0) THEN
40133 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1