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(4000,2),BRAT(4000),KFDP(4000,5)
174 **LUND single / double precision
175 REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
176 COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
177 & TMPX,TMPY,TMPW2,TMPQ2,TMPU
180 COMMON /LEPTOI/ RPPN,LEPIN,INTER
181 * steering flags for qel neutrino scattering modules
182 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
184 COMMON /DTEVNO/ NEVENT,ICASCA
189 DIMENSION XDUMB(40),IPRANG(5)
191 PARAMETER (MXCARD=58)
192 CHARACTER*78 CLINE,CTITLE
194 CHARACTER*8 BLANK,SDUM
195 CHARACTER*10 CODE,CODEWD
197 LOGICAL LSTART,LEINP,LXSTAB
198 DIMENSION WHAT(6),CODE(MXCARD)
200 & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ',
201 & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ',
202 & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ',
203 & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ',
204 & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ',
205 & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ',
206 & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ',
207 & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ',
208 & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ',
209 & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
210 & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ',
211 & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ',
212 & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ',
213 & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
217 DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
220 *---------------------------------------------------------------------
221 * at the first call of INIT: initialize event generation
225 * initialization and test of the random number generator
226 IF (ITRSPT.NE.1) THEN
227 CALL DT_RNDMST(22,54,76,92)
230 * initialization of BAMJET, DECAY and HADRIN
235 * set default values for input variables
236 CALL DT_DEFAUL(EPN,PPN)
239 * flag for collision energy input
244 *---------------------------------------------------------------------
247 * bypass reading input cards (e.g. for use with Fluka)
248 * in this case Epn is expected to carry the beam momentum
249 IF (NCASES.EQ.-1) THEN
263 * read control card from input-unit LINP
264 READ(LINP,'(A78)',END=9999) CLINE
265 IF (CLINE(1:1).EQ.'*') THEN
267 WRITE(LOUT,'(A78)') CLINE
270 C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
271 C1000 FORMAT(A10,6E10.0,A8)
275 READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
276 1006 FORMAT(A10,A60,A8)
277 READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
279 WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
280 1001 FORMAT(A10,6G10.3,A8)
284 * check for valid control card and get card index
287 IF (CODEWD.EQ.CODE(I)) ICW = I
290 WRITE(LOUT,1002) CODEWD
291 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
296 *------------------------------------------------------------
297 * TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM,
298 & 100 , 110 , 120 , 130 , 140 ,
300 *------------------------------------------------------------
301 * CMENERGY, EMULSION, FERMI , TAUFOR , PAULI ,
302 & 150 , 160 , 170 , 180 , 190 ,
304 *------------------------------------------------------------
305 * COULOMB , HADRIN , EVAP , EMCCHECK, MODEL ,
306 & 200 , 210 , 220 , 230 , 240 ,
308 *------------------------------------------------------------
309 * PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN,
310 & 250 , 260 , 270 , 280 , 290 ,
312 *------------------------------------------------------------
313 * COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR,
314 & 300 , 310 , 320 , 330 , 340 ,
316 *------------------------------------------------------------
317 * SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH,
318 & 350 , 360 , 370 , 380 , 390 ,
320 *------------------------------------------------------------
321 * NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM ,
322 & 400 , 410 , 420 , 430 , 440 ,
324 *------------------------------------------------------------
325 * LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
326 & 450 , 451 , 452 , 460 , 470 ,
328 *------------------------------------------------------------
329 * OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT,
330 & 480 , 490 , 500 , 510 , 520 ,
332 *------------------------------------------------------------
333 * VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
334 & 530 , 540 , 550 , 560 , 565 ,
336 *------------------------------------------------------------
337 * , , VDM-PAR2, XS-QELPRO, RNDMINIT ,
340 *------------------------------------------------------------
341 * LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP )
342 & 600 , 610 , 620 , 630 , 640 ) , ICW
344 *------------------------------------------------------------
348 *********************************************************************
350 * control card: codewd = TITLE *
352 * what (1..6), sdum no meaning *
354 * Note: The control-card following this must consist of *
355 * a string of characters usually giving the title of *
358 *********************************************************************
361 READ(LINP,'(A78)') CTITLE
362 WRITE(LOUT,'(//,5X,A78,//)') CTITLE
365 *********************************************************************
367 * control card: codewd = PROJPAR *
369 * what (1) = mass number of projectile nucleus default: 1 *
370 * what (2) = charge of projectile nucleus default: 1 *
371 * what (3..6) no meaning *
372 * sdum projectile particle code word *
374 * Note: If sdum is defined what (1..2) have no meaning. *
376 *********************************************************************
379 IF (SDUM.EQ.BLANK) THEN
387 IF (SDUM.EQ.BTYPE(II)) THEN
392 ELSEIF (II.EQ.27) THEN
394 ELSEIF (II.EQ.28) THEN
396 ELSEIF (II.EQ.29) THEN
401 IBPROJ = IIBAR(IJPROJ)
403 IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
405 IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
406 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
407 & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
410 IF (IJPROJ.EQ.0) THEN
412 1110 FORMAT(/,1X,'invalid PROJPAR card !',/)
418 *********************************************************************
420 * control card: codewd = TARPAR *
422 * what (1) = mass number of target nucleus default: 1 *
423 * what (2) = charge of target nucleus default: 1 *
424 * what (3..6) no meaning *
425 * sdum target particle code word *
427 * Note: If sdum is defined what (1..2) have no meaning. *
429 *********************************************************************
432 IF (SDUM.EQ.BLANK) THEN
440 IF (SDUM.EQ.BTYPE(II)) THEN
444 IBTARG = IIBAR(IJTARG)
447 IF (IJTARG.EQ.0) THEN
449 1120 FORMAT(/,1X,'invalid TARPAR card !',/)
455 *********************************************************************
457 * control card: codewd = ENERGY *
459 * what (1) = energy (GeV) of projectile in Lab. *
460 * if what(1) < 0: |what(1)| = kinetic energy *
462 * if |what(2)| > 0: min. energy for variable *
464 * what (2) = max. energy for variable energy runs *
465 * if what(2) < 0: |what(2)| = kinetic energy *
467 *********************************************************************
473 IF ((ABS(WHAT(2)).GT.ZERO).AND.
474 & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
482 *********************************************************************
484 * control card: codewd = MOMENTUM *
486 * what (1) = momentum (GeV/c) of projectile in Lab. *
487 * default: 200 GeV/c *
488 * what (2..6), sdum no meaning *
490 *********************************************************************
499 *********************************************************************
501 * control card: codewd = CMENERGY *
503 * what (1) = energy in nucleon-nucleon cms. *
505 * what (2..6), sdum no meaning *
507 *********************************************************************
516 *********************************************************************
518 * control card: codewd = EMULSION *
520 * definition of nuclear emulsions *
522 * what(1) mass number of emulsion component *
523 * what(2) charge of emulsion component *
524 * what(3) fraction of events in which a scattering on a *
525 * nucleus of this properties is performed *
526 * what(4,5,6) as what(1,2,3) but for another component *
527 * default: no emulsion *
530 * Note: If this input-card is once used with valid parameters *
531 * TARPAR is obsolete. *
532 * Not the absolute values of the fractions are important *
533 * but only the ratios of fractions of different comp. *
534 * This control card can be repeatedly used to define *
535 * emulsions consisting of up to 10 elements. *
537 *********************************************************************
540 IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
541 & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
543 IF (NCOMPO.GT.NCOMPX) THEN
547 IEMUMA(NCOMPO) = INT(WHAT(1))
548 IEMUCH(NCOMPO) = INT(WHAT(2))
549 EMUFRA(NCOMPO) = WHAT(3)
551 C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
553 IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
554 & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
556 IF (NCOMPO.GT.NCOMPX) THEN
560 IEMUMA(NCOMPO) = INT(WHAT(4))
561 IEMUCH(NCOMPO) = INT(WHAT(5))
562 EMUFRA(NCOMPO) = WHAT(6)
563 C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
565 1600 FORMAT(1X,'too many emulsion components - program stopped')
568 *********************************************************************
570 * control card: codewd = FERMI *
572 * what (1) = -1 Fermi-motion of nucleons not treated *
574 * what (2) = scale factor for Fermi-momentum *
576 * what (3..6), sdum no meaning *
578 *********************************************************************
581 IF (WHAT(1).EQ.-1.0D0) THEN
587 IF (XMOD.GE.ZERO) FERMOD = XMOD
590 *********************************************************************
592 * control card: codewd = TAUFOR *
594 * formation time supressed intranuclear cascade *
596 * what (1) formation time (in fm/c) *
597 * note: what(1)=10. corresponds roughly to an *
598 * average formation time of 1 fm/c *
600 * what (2) number of generations followed *
602 * what (3) = 1. p_t-dependent formation zone *
603 * = 2. constant formation zone *
605 * what (4) modus of selection of nucleus where the *
606 * cascade if followed first *
607 * = 1. proj./target-nucleus with probab. 1/2 *
608 * = 2. nucleus with highest mass *
609 * = 3. proj. nucleus if particle is moving in pos. z *
610 * targ. nucleus if particle is moving in neg. z *
612 * what (5..6), sdum no meaning *
614 *********************************************************************
618 KTAUGE = INT(WHAT(2))
620 IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
621 & ITAUVE = INT(WHAT(3))
622 IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
623 & INCMOD = INT(WHAT(4))
626 *********************************************************************
628 * control card: codewd = PAULI *
630 * what (1) = -1 Pauli's principle for secondary *
631 * interactions not treated *
633 * what (2..6), sdum no meaning *
635 *********************************************************************
638 IF (WHAT(1).EQ.-1.0D0) THEN
645 *********************************************************************
647 * control card: codewd = COULOMB *
649 * what (1) = -1. Coulomb-energy treatment switched off *
651 * what (2..6), sdum no meaning *
653 *********************************************************************
657 IF (WHAT(1).EQ.-1.0D0) THEN
664 *********************************************************************
666 * control card: codewd = HADRIN *
670 * what (1) = 0. elastic/inelastic interactions with probab. *
671 * as defined by cross-sections *
672 * = 1. inelastic interactions forced *
673 * = 2. elastic interactions forced *
675 * what (2) upper threshold in total energy (GeV) below *
676 * which interactions are sampled by HADRIN *
678 * what (3..6), sdum no meaning *
680 *********************************************************************
684 IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
685 IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
688 *********************************************************************
690 * control card: codewd = EVAP *
692 * evaporation module *
694 * what (1) =< -1 ==> evaporation is switched off *
695 * >= 1 ==> evaporation is performed *
697 * what (1) = i1 + i2*10 + i3*100 + i4*10000 *
698 * (i1, i2, i3, i4 >= 0 ) *
700 * i1 is the flag for selecting the T=0 level density option used *
701 * = 1: standard EVAP level densities with Cook pairing *
703 * = 2: Z,N-dependent Gilbert & Cameron level densities *
705 * = 3: Julich A-dependent level densities *
706 * = 4: Z,N-dependent Brancazio & Cameron level densities *
708 * i2 >= 1: high energy fission activated *
709 * (default high energy fission activated) *
711 * i3 = 0: No energy dependence for level densities *
712 * = 1: Standard Ignyatuk (1975, 1st) energy dependence *
713 * for level densities (default) *
714 * = 2: Standard Ignyatuk (1975, 1st) energy dependence *
715 * for level densities with NOT used set of parameters *
716 * = 3: Standard Ignyatuk (1975, 1st) energy dependence *
717 * for level densities with NOT used set of parameters *
718 * = 4: Second Ignyatuk (1975, 2nd) energy dependence *
719 * for level densities *
720 * = 5: Second Ignyatuk (1975, 2nd) energy dependence *
721 * for level densities with fit 1 Iljinov & Mebel set of *
723 * = 6: Second Ignyatuk (1975, 2nd) energy dependence *
724 * for level densities with fit 2 Iljinov & Mebel set of *
726 * = 7: Second Ignyatuk (1975, 2nd) energy dependence *
727 * for level densities with fit 3 Iljinov & Mebel set of *
729 * = 8: Second Ignyatuk (1975, 2nd) energy dependence *
730 * for level densities with fit 4 Iljinov & Mebel set of *
733 * i4 >= 1: Original Gilbert and Cameron pairing energies used *
734 * (default Cook's modified pairing energies) *
736 * what (2) = ig + 10 * if (ig and if must have the same sign) *
738 * ig =< -1 ==> deexcitation gammas are not produced *
739 * (if the evaporation step is not performed *
740 * they are never produced) *
741 * if =< -1 ==> Fermi Break Up is not invoked *
742 * (if the evaporation step is not performed *
743 * it is never invoked) *
744 * The default is: deexcitation gamma produced and Fermi break up *
745 * activated for the new preequilibrium, not *
746 * activated otherwise. *
747 * what (3..6), sdum no meaning *
749 *********************************************************************
753 1009 FORMAT(1X,/,'Warning! Evaporation request rejected since',
754 & ' evaporation modules not available with this version.')
764 *********************************************************************
766 * control card: codewd = EMCCHECK *
768 * extended energy-momentum / quantum-number conservation check *
770 * what (1) = -1 extended check not performed *
772 * what (2..6), sdum no meaning *
774 *********************************************************************
777 IF (WHAT(1).EQ.-1) THEN
784 *********************************************************************
786 * control card: codewd = MODEL *
788 * Model to be used to treat nucleon-nucleon interactions *
790 * sdum = DTUNUC two-chain model *
791 * = PHOJET multiple chains including minijets *
793 * = QNEUTRIN quasi-elastic neutrino scattering *
797 * what (1) (variable INTER) *
798 * = 1 gamma exchange *
801 * = 4 gamma/Z0 exchange *
803 * if sdum = QNEUTRIN: *
804 * what (1) = 0 elastic scattering on nucleon and *
805 * tau does not decay (default) *
806 * = 1 decay of tau into mu.. *
807 * = 2 decay of tau into e.. *
808 * = 10 CC events on p and n *
809 * = 11 NC events on p and n *
811 * what (2..6) no meaning *
813 *********************************************************************
816 IF (SDUM.EQ.CMODEL(1)) THEN
818 ELSEIF (SDUM.EQ.CMODEL(2)) THEN
820 ELSEIF (SDUM.EQ.CMODEL(3)) THEN
822 IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
823 & INTER = INT(WHAT(1))
824 ELSEIF (SDUM.EQ.CMODEL(4)) THEN
827 IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
828 & (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
831 STOP ' Unknown model !'
835 *********************************************************************
837 * control card: codewd = PHOINPUT *
839 * Start of input-section for PHOJET-specific input-cards *
840 * Note: This section will not be finished before giving *
842 * what (1..6), sdum no meaning *
844 *********************************************************************
848 CALL PHO_INIT(LINP,LOUT,IREJ1)
850 WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed'
857 *********************************************************************
859 * control card: codewd = GLAUBERI *
861 * Pre-initialization of impact parameter selection *
863 * what (1..6), sdum no meaning *
865 *********************************************************************
868 IF (IFIRST.NE.99) THEN
869 CALL DT_RNDMST(12,34,56,78)
871 OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
872 C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
883 ADP = (APHI-APLOW)/DBLE(IPPN)
904 IT = ITLOW+(NCIT-1)*IDIT
907 C IIP = (IPHI-IPLOW)/IDIP
908 C IF (IIP.EQ.0) IIP = 1
909 C IF (IT.EQ.IPLOW) IIP = 0
913 CC IF (NCIP.LE.IIP) THEN
914 C IP = IPLOW+(NCIP-1)*IDIP
918 IF (IP.GT.IT) GOTO 472
921 APPN = APLOW+DBLE(NCP-1)*ADP
924 OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
925 WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
932 CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
933 CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
936 C IF ((IP.GT.10).OR.(IT.GT.10)) THEN
944 CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
945 SIGAV = SIGAV+XSPRO(1,1,1)
948 CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
954 C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
957 C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
958 C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
968 *********************************************************************
970 * control card: codewd = FLUCTUAT *
972 * Treatment of cross section fluctuations *
974 * what (1) = 1 treat cross section fluctuations *
976 * what (1..6), sdum no meaning *
978 *********************************************************************
982 IF (WHAT(1).EQ.ONE) THEN
988 *********************************************************************
990 * control card: codewd = CENTRAL *
992 * what (1) = 1. central production forced default: 0 *
993 * if what (1) < 0 and > -100 *
994 * what (2) = min. impact parameter default: 0 *
995 * what (3) = max. impact parameter default: b_max *
996 * if what (1) < -99 *
997 * what (2) = fraction of cross section default: 1 *
998 * if what (1) = -1 : evaporation/fzc suppressed *
999 * if what (1) < -1 : evaporation/fzc allowed *
1001 * what (4..6), sdum no meaning *
1003 *********************************************************************
1006 ICENTR = INT(WHAT(1))
1007 IF (ICENTR.LT.0) THEN
1008 IF (ICENTR.GT.-100) THEN
1017 *********************************************************************
1019 * control card: codewd = RECOMBIN *
1021 * Chain recombination *
1022 * (recombine S-S and V-V chains to V-S chains) *
1024 * what (1) = -1. recombination switched off default: 1 *
1025 * what (2..6), sdum no meaning *
1027 *********************************************************************
1031 IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1034 *********************************************************************
1036 * control card: codewd = COMBIJET *
1038 * chain fusion (2 q-aq --> qq-aqaq) *
1040 * what (1) = 1 fusion treated *
1042 * what (2) minimum number of uncombined chains from *
1043 * single projectile or target nucleons *
1045 * what (3..6), sdum no meaning *
1047 *********************************************************************
1051 IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1052 IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1055 *********************************************************************
1057 * control card: codewd = XCUTS *
1059 * thresholds for x-sampling *
1061 * what (1) defines lower threshold for val.-q x-value (CVQ) *
1063 * what (2) defines lower threshold for val.-qq x-value (CDQ) *
1065 * what (3) defines lower threshold for sea-q x-value (CSEA) *
1067 * what (4) sea-q x-values in S-S chains (SSMIMA) *
1069 * what (5) not used *
1071 * what (6), sdum no meaning *
1073 * Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1075 *********************************************************************
1078 IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1)
1079 IF (WHAT(2).GE.ONE) CDQ = WHAT(2)
1080 IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3)
1081 IF (WHAT(4).GE.ZERO) THEN
1085 IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1088 *********************************************************************
1090 * control card: codewd = INTPT *
1092 * what (1) = -1 intrinsic transverse momenta of partons *
1093 * not treated default: 1 *
1094 * what (2..6), sdum no meaning *
1096 *********************************************************************
1099 IF (WHAT(1).EQ.-1.0D0) THEN
1106 *********************************************************************
1108 * control card: codewd = CRONINPT *
1110 * Cronin effect (multiple scattering of partons at chain ends) *
1112 * what (1) = -1 Cronin effect not treated default: 1 *
1113 * what (2) = 0 scattering parameter default: 0.64 *
1114 * what (3..6), sdum no meaning *
1116 *********************************************************************
1119 IF (WHAT(1).EQ.-1.0D0) THEN
1127 *********************************************************************
1129 * control card: codewd = SEADISTR *
1131 * what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. *
1132 * what (2) (UNON) default: 2. *
1133 * what (3) (UNOM) default: 1.5 *
1134 * what (4) (UNOSEA) default: 5. *
1135 * qdis(x) prop. (1-x)**what (1) etc. *
1136 * what (5..6), sdum no meaning *
1138 *********************************************************************
1142 XSEACU = 1.05D0-XSEACO
1144 IF (UNON.LT.0.1D0) UNON = 2.0D0
1146 IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1148 IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1151 *********************************************************************
1153 * control card: codewd = SEASU3 *
1155 * Treatment of strange-quarks at chain ends *
1157 * what (1) (SEASQ) strange-quark supression factor *
1158 * iflav = 1.+rndm*(2.+SEASQ) *
1160 * what (2..6), sdum no meaning *
1162 *********************************************************************
1168 *********************************************************************
1170 * control card: codewd = DIQUARKS *
1172 * what (1) = -1. sea-diquark/antidiquark-pairs not treated *
1174 * what (2..6), sdum no meaning *
1176 *********************************************************************
1179 IF (WHAT(1).EQ.-1.0D0) THEN
1186 *********************************************************************
1188 * control card: codewd = RESONANC *
1190 * treatment of low mass chains *
1192 * what (1) = -1 low chain masses are not corrected for resonance *
1193 * masses (obsolete for BAMJET-fragmentation) *
1195 * what (2) = -1 massless partons default: 1. (massive) *
1196 * default: 1. (massive) *
1197 * what (3) = -1 chain-system containing chain of too small *
1198 * mass is rejected (note: this does not fully *
1199 * apply to S-S chains) default: 0. *
1200 * what (4..6), sdum no meaning *
1202 *********************************************************************
1208 IF (WHAT(1).EQ.-ONE) IRESCO = 0
1209 IF (WHAT(2).EQ.-ONE) IMSHL = 0
1210 IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1213 *********************************************************************
1215 * control card: codewd = DIFFRACT *
1217 * Treatment of diffractive events *
1219 * what (1) = (ISINGD) 0 no single diffraction *
1220 * 1 single diffraction included *
1221 * +-2 single diffractive events only *
1222 * +-3 projectile single diffraction only *
1223 * +-4 target single diffraction only *
1224 * -5 double pomeron exchange only *
1225 * (neg. sign applies to PHOJET events) *
1228 * what (2) = (IDOUBD) 0 no double diffraction *
1229 * 1 double diffraction included *
1230 * 2 double diffractive events only *
1232 * what (3) = 1 projectile diffraction treated (2-channel form.) *
1234 * what (4) = alpha-parameter in projectile diffraction *
1236 * what (5..6), sdum no meaning *
1238 *********************************************************************
1241 IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1242 IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1243 IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1245 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/,
1246 & 11X,'IDOUBD is reset to zero')
1249 IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1250 IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1253 *********************************************************************
1255 * control card: codewd = SINGLECH *
1257 * what (1) = 1. Regge contribution (one chain) included *
1259 * what (2..6), sdum no meaning *
1261 *********************************************************************
1265 IF (WHAT(1).EQ.ONE) ISICHA = 1
1268 *********************************************************************
1270 * control card: codewd = NOFRAGME *
1272 * biased chain hadronization *
1274 * what (1..6) = -1 no of hadronizsation of S-S chains *
1275 * = -2 no of hadronizsation of D-S chains *
1276 * = -3 no of hadronizsation of S-D chains *
1277 * = -4 no of hadronizsation of S-V chains *
1278 * = -5 no of hadronizsation of D-V chains *
1279 * = -6 no of hadronizsation of V-S chains *
1280 * = -7 no of hadronizsation of V-D chains *
1281 * = -8 no of hadronizsation of V-V chains *
1282 * = -9 no of hadronizsation of comb. chains *
1283 * default: complete hadronization *
1286 *********************************************************************
1290 ICHAIN = INT(WHAT(I))
1291 IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1292 & LHADRO(ABS(ICHAIN)) = .FALSE.
1296 *********************************************************************
1298 * control card: codewd = HADRONIZE *
1300 * hadronization model and parameter switch *
1302 * what (1) = 1 hadronization via BAMJET *
1303 * = 2 hadronization via JETSET *
1305 * what (2) = 1..3 parameter set to be used *
1306 * JETSET: 3 sets available *
1307 * ( = 3 default JETSET-parameters) *
1308 * BAMJET: 1 set available *
1310 * what (3..6), sdum no meaning *
1312 *********************************************************************
1315 IWHAT1 = INT(WHAT(1))
1316 IWHAT2 = INT(WHAT(2))
1317 IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1318 IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1322 *********************************************************************
1324 * control card: codewd = POPCORN *
1326 * "Popcorn-effect" in fragmentation and diquark breaking diagrams *
1328 * what (1) = (PDB) frac. of diquark fragmenting directly into *
1329 * baryons (PYTHIA/JETSET fragmentation) *
1330 * (JETSET: = 0. Popcorn mechanism switched off) *
1332 * what (2) = probability for accepting a diquark breaking *
1333 * diagram involving the generation of a u/d quark- *
1334 * antiquark pair default: 0.0 *
1335 * what (3) = same a what (2), here for s quark-antiquark pair *
1337 * what (4..6), sdum no meaning *
1339 *********************************************************************
1342 IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1343 IF (WHAT(2).GE.0.0D0) THEN
1347 IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1349 DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1350 DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1351 DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1355 *********************************************************************
1357 * control card: codewd = PARDECAY *
1359 * what (1) = 1. Sigma0/Asigma0 are decaying within JETSET *
1360 * = 2. pion^0 decay after intranucl. cascade *
1361 * default: no decay *
1362 * what (2..6), sdum no meaning *
1364 *********************************************************************
1367 IF (WHAT(1).EQ.ONE) ISIG0 = 1
1368 IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1371 *********************************************************************
1373 * control card: codewd = BEAM *
1375 * definition of beam parameters *
1377 * what (1/2) > 0 : energy of beam 1/2 (GeV) *
1378 * < 0 : abs(what(1/2)) energy per charge of *
1380 * (beam 1 is directed into positive z-direction) *
1381 * what (3) beam crossing angle, defined as 2x angle between *
1382 * one beam and the z-axis (micro rad) *
1383 * what (4) angle with x-axis defining the collision plane *
1384 * what (5..6), sdum no meaning *
1386 * Note: this card requires previously defined projectile and *
1387 * target identities (PROJPAR, TARPAR) *
1389 *********************************************************************
1392 CALL DT_BEAMPR(WHAT,PPN,1)
1398 *********************************************************************
1400 * control card: codewd = LUND-MSTU *
1402 * set parameter MSTU in JETSET-common /LUDAT1/ *
1404 * what (1) = index according to LUND-common block *
1405 * what (2) = new value of MSTU( int(what(1)) ) *
1406 * what (3), what(4) and what (5), what(6) further *
1407 * parameter in the same way as what (1) and *
1409 * default: default-Lund or corresponding to *
1410 * the set given in HADRONIZE *
1412 *********************************************************************
1415 IF (WHAT(1).GT.ZERO) THEN
1417 IMSTU(NMSTU) = INT(WHAT(1))
1418 MSTUX(NMSTU) = INT(WHAT(2))
1420 IF (WHAT(3).GT.ZERO) THEN
1422 IMSTU(NMSTU) = INT(WHAT(3))
1423 MSTUX(NMSTU) = INT(WHAT(4))
1425 IF (WHAT(5).GT.ZERO) THEN
1427 IMSTU(NMSTU) = INT(WHAT(5))
1428 MSTUX(NMSTU) = INT(WHAT(6))
1432 *********************************************************************
1434 * control card: codewd = LUND-MSTJ *
1436 * set parameter MSTJ in JETSET-common /LUDAT1/ *
1438 * what (1) = index according to LUND-common block *
1439 * what (2) = new value of MSTJ( int(what(1)) ) *
1440 * what (3), what(4) and what (5), what(6) further *
1441 * parameter in the same way as what (1) and *
1443 * default: default-Lund or corresponding to *
1444 * the set given in HADRONIZE *
1446 *********************************************************************
1449 IF (WHAT(1).GT.ZERO) THEN
1451 IMSTJ(NMSTJ) = INT(WHAT(1))
1452 MSTJX(NMSTJ) = INT(WHAT(2))
1454 IF (WHAT(3).GT.ZERO) THEN
1456 IMSTJ(NMSTJ) = INT(WHAT(3))
1457 MSTJX(NMSTJ) = INT(WHAT(4))
1459 IF (WHAT(5).GT.ZERO) THEN
1461 IMSTJ(NMSTJ) = INT(WHAT(5))
1462 MSTJX(NMSTJ) = INT(WHAT(6))
1466 *********************************************************************
1468 * control card: codewd = LUND-MDCY *
1470 * set parameter MDCY(I,1) for particle decays in JETSET-common *
1473 * what (1-6) = PDG particle index of particle which should *
1475 * default: default-Lund or forced in *
1478 *********************************************************************
1482 IF (WHAT(I).NE.ZERO) THEN
1483 KC = PYCOMP(INT(WHAT(I)))
1489 *********************************************************************
1491 * control card: codewd = LUND-PARJ *
1493 * set parameter PARJ in JETSET-common /LUDAT1/ *
1495 * what (1) = index according to LUND-common block *
1496 * what (2) = new value of PARJ( int(what(1)) ) *
1497 * what (3), what(4) and what (5), what(6) further *
1498 * parameter in the same way as what (1) and *
1500 * default: default-Lund or corresponding to *
1501 * the set given in HADRONIZE *
1503 *********************************************************************
1506 IF (WHAT(1).NE.ZERO) THEN
1508 IPARJ(NPARJ) = INT(WHAT(1))
1509 PARJX(NPARJ) = WHAT(2)
1511 IF (WHAT(3).NE.ZERO) THEN
1513 IPARJ(NPARJ) = INT(WHAT(3))
1514 PARJX(NPARJ) = WHAT(4)
1516 IF (WHAT(5).NE.ZERO) THEN
1518 IPARJ(NPARJ) = INT(WHAT(5))
1519 PARJX(NPARJ) = WHAT(6)
1523 *********************************************************************
1525 * control card: codewd = LUND-PARU *
1527 * set parameter PARJ in JETSET-common /LUDAT1/ *
1529 * what (1) = index according to LUND-common block *
1530 * what (2) = new value of PARU( int(what(1)) ) *
1531 * what (3), what(4) and what (5), what(6) further *
1532 * parameter in the same way as what (1) and *
1534 * default: default-Lund or corresponding to *
1535 * the set given in HADRONIZE *
1537 *********************************************************************
1540 IF (WHAT(1).GT.ZERO) THEN
1542 IPARU(NPARU) = INT(WHAT(1))
1543 PARUX(NPARU) = WHAT(2)
1545 IF (WHAT(3).GT.ZERO) THEN
1547 IPARU(NPARU) = INT(WHAT(3))
1548 PARUX(NPARU) = WHAT(4)
1550 IF (WHAT(5).GT.ZERO) THEN
1552 IPARU(NPARU) = INT(WHAT(5))
1553 PARUX(NPARU) = WHAT(6)
1557 *********************************************************************
1559 * control card: codewd = OUTLEVEL *
1561 * output control switches *
1563 * what (1) = internal rejection informations default: 0 *
1564 * what (2) = energy-momentum conservation check output *
1566 * what (3) = internal warning messages default: 0 *
1567 * what (4..6), sdum not yet used *
1569 *********************************************************************
1573 IOULEV(K) = INT(WHAT(K))
1577 *********************************************************************
1579 * control card: codewd = FRAME *
1581 * frame in which final state is given in DTEVT1 *
1583 * what (1) = 1 target rest frame (laboratory) *
1584 * = 2 nucleon-nucleon cms *
1587 *********************************************************************
1590 KFRAME = INT(WHAT(1))
1591 IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1594 *********************************************************************
1596 * control card: codewd = L-TAG *
1599 * definition of kinematical cuts for radiated photon and *
1600 * outgoing lepton detection in lepton-nucleus interactions *
1602 * what (1) = y_min *
1603 * what (2) = y_max *
1604 * what (3) = Q^2_min *
1605 * what (4) = Q^2_max *
1606 * what (5) = theta_min (Lab) *
1607 * what (6) = theta_max (Lab) *
1608 * default: no cuts *
1611 *********************************************************************
1622 *********************************************************************
1624 * control card: codewd = L-ETAG *
1627 * what (1) = min. outgoing lepton energy (in Lab) *
1628 * what (2) = min. photon energy (in Lab) *
1629 * what (3) = max. photon energy (in Lab) *
1630 * default: no cuts *
1631 * what (2..6), sdum no meaning *
1633 *********************************************************************
1636 ELMIN = MAX(WHAT(1),ZERO)
1637 EGMIN = MAX(WHAT(2),ZERO)
1638 EGMAX = MAX(WHAT(3),ZERO)
1641 *********************************************************************
1643 * control card: codewd = ECMS-CUT *
1645 * what (1) = min. c.m. energy to be sampled *
1646 * what (2) = max. c.m. energy to be sampled *
1647 * what (3) = min x_Bj to be sampled *
1648 * default: no cuts *
1649 * what (3..6), sdum no meaning *
1651 *********************************************************************
1656 IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1657 XBJMIN = MAX(WHAT(3),ZERO)
1660 *********************************************************************
1662 * control card: codewd = VDM-PAR1 *
1664 * parameters in gamma-nucleus cross section calculation *
1666 * what (1) = Lambda^2 default: 2. *
1667 * what (2) lower limit in M^2 integration *
1670 * = 3 (m_phi)^2 default: 1 *
1671 * what (3) upper limit in M^2 integration *
1674 * = 3 s default: 3 *
1675 * what (4) CKMT F_2 structure function *
1677 * = 100 deuteron default: 2212 *
1678 * what (5) calculation of gamma-nucleon xsections *
1679 * = 1 according to CKMT-parametrization of F_2 *
1680 * = 2 integrating SIGVP over M^2 *
1682 * = 4 PHOJET cross sections default: 4 *
1684 * what (6), sdum no meaning *
1686 *********************************************************************
1689 IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1690 IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1691 IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1692 IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1693 IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1696 *********************************************************************
1698 * control card: codewd = HISTOGRAM *
1700 * activate different classes of histograms *
1702 * default: no histograms *
1704 *********************************************************************
1708 IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1709 IHISPP(INT(WHAT(J))-100) = 1
1710 ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1711 IHISXS(INT(ABS(WHAT(J)))-200) = 1
1712 IF (WHAT(J).LT.ZERO) IXSTBL = 1
1717 *********************************************************************
1719 * control card: codewd = XS-TABLE *
1721 * output of cross section table for requested interaction *
1722 * - particle production deactivated ! - *
1724 * what (1) lower energy limit for tabulation *
1726 * < 0 nucleon-nucleon cms *
1727 * what (2) upper energy limit for tabulation *
1729 * < 0 nucleon-nucleon cms *
1730 * what (3) > 0 # of equidistant lin. bins in E *
1731 * < 0 # of equidistant log. bins in E *
1732 * what (4) lower limit of particle virtuality (photons) *
1733 * what (5) upper limit of particle virtuality (photons) *
1734 * what (6) > 0 # of equidistant lin. bins in Q^2 *
1735 * < 0 # of equidistant log. bins in Q^2 *
1737 *********************************************************************
1740 IF (WHAT(1).EQ.99999.0D0) THEN
1741 IRATIO = INT(WHAT(2))
1744 CMENER = ABS(WHAT(2))
1745 IF (.NOT.LXSTAB) THEN
1749 IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1751 IF (WHAT(2).GT.ZERO)
1752 & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1755 C WRITE(LOUT,*) 'CMENER = ',CMENER
1756 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1759 CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1764 *********************************************************************
1766 * control card: codewd = GLAUB-PAR *
1768 * parameters in Glauber-formalism *
1770 * what (1) # of nucleon configurations sampled in integration *
1771 * over nuclear desity default: 1000 *
1772 * what (2) # of bins for integration over impact-parameter and *
1773 * for profile-function calculation default: 49 *
1774 * what (3) = 1 calculation of tot., el. and qel. cross sections *
1776 * what (4) = 1 read pre-calculated impact-parameter distrib. *
1778 * =-1 dump pre-calculated impact-parameter distrib. *
1780 * = 100 read pre-calculated impact-parameter distrib. *
1781 * for variable projectile/target/energy runs *
1784 * what (5..6) no meaning *
1785 * sdum if |what (4)| = 1 name of in/output-file (sdum.glb) *
1787 *********************************************************************
1790 IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1791 IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1792 IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1793 IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1794 IOGLB = INT(WHAT(4))
1799 *********************************************************************
1801 * control card: codewd = GLAUB-INI *
1803 * pre-initialization of profile function *
1805 * what (1) lower energy limit for initialization *
1807 * < 0 nucleon-nucleon cms *
1808 * what (2) upper energy limit for initialization *
1810 * < 0 nucleon-nucleon cms *
1811 * what (3) > 0 # of equidistant lin. bins in E *
1812 * < 0 # of equidistant log. bins in E *
1813 * what (4) maximum projectile mass number for which the *
1814 * Glauber data are initialized for each *
1815 * projectile mass number *
1816 * (if <= mass given with the PROJPAR-card) *
1818 * what (5) steps in mass number starting from what (4) *
1819 * up to mass number defined with PROJPAR-card *
1820 * for which Glauber data are initialized *
1822 * what (6) no meaning *
1825 *********************************************************************
1829 CALL DT_GLBINI(WHAT)
1832 *********************************************************************
1834 * control card: codewd = VDM-PAR2 *
1836 * parameters in gamma-nucleus cross section calculation *
1838 * what (1) = 0 no suppression of shadowing by direct photon *
1840 * = 1 suppression .. default: 1 *
1841 * what (2) = 0 no suppression of shadowing by anomalous *
1842 * component if photon-F_2 *
1843 * = 1 suppression .. default: 1 *
1844 * what (3) = 0 no suppression of shadowing by coherence *
1845 * length of the photon *
1846 * = 1 suppression .. default: 1 *
1847 * what (4) = 1 longitudinal polarized photons are taken into *
1849 * eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 *
1850 * what (5..6), sdum no meaning *
1852 *********************************************************************
1855 IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
1856 IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
1857 IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
1861 *********************************************************************
1863 * control card: XS-QELPRO *
1865 * what (1..6), sdum no meaning *
1867 *********************************************************************
1870 IXSQEL = ABS(WHAT(1))
1873 *********************************************************************
1875 * control card: RNDMINIT *
1877 * initialization of random number generator *
1879 * what (1..4) values for initialization (= 1..168) *
1880 * what (5..6), sdum no meaning *
1882 *********************************************************************
1885 IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
1890 IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
1895 IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
1900 IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
1905 CALL DT_RNDMST(NA1,NA2,NA3,NA4)
1908 *********************************************************************
1910 * control card: codewd = LEPTO-CUT *
1912 * set parameter CUT in LEPTO-common /LEPTOU/ *
1914 * what (1) = index in CUT-array *
1915 * what (2) = new value of CUT( int(what(1)) ) *
1916 * what (3), what(4) and what (5), what(6) further *
1917 * parameter in the same way as what (1) and *
1919 * default: default-LEPTO parameters *
1921 *********************************************************************
1924 IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
1925 IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
1926 IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
1929 *********************************************************************
1931 * control card: codewd = LEPTO-LST *
1933 * set parameter LST in LEPTO-common /LEPTOU/ *
1935 * what (1) = index in LST-array *
1936 * what (2) = new value of LST( int(what(1)) ) *
1937 * what (3), what(4) and what (5), what(6) further *
1938 * parameter in the same way as what (1) and *
1940 * default: default-LEPTO parameters *
1942 *********************************************************************
1945 IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
1946 IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
1947 IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
1950 *********************************************************************
1952 * control card: codewd = LEPTO-PARL *
1954 * set parameter PARL in LEPTO-common /LEPTOU/ *
1956 * what (1) = index in PARL-array *
1957 * what (2) = new value of PARL( int(what(1)) ) *
1958 * what (3), what(4) and what (5), what(6) further *
1959 * parameter in the same way as what (1) and *
1961 * default: default-LEPTO parameters *
1963 *********************************************************************
1966 IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
1967 IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
1968 IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
1971 *********************************************************************
1973 * control card: codewd = START *
1975 * what (1) = number of events default: 100. *
1976 * what (2) = 0 Glauber initialization follows *
1977 * = 1 Glauber initialization supressed, fitted *
1978 * results are used instead *
1979 * (this does not apply if emulsion-treatment *
1981 * = 2 Glauber initialization is written to *
1982 * output-file shmakov.out *
1983 * = 3 Glauber initialization is read from input-file *
1984 * shmakov.out default: 0 *
1985 * what (3..6) no meaning *
1986 * what (3..6) no meaning *
1988 *********************************************************************
1992 * check for cross-section table output only
1995 NCASES = INT(WHAT(1))
1996 IF (NCASES.LE.0) NCASES = 100
1997 IGLAU = INT(WHAT(2))
1998 IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
2007 IF (IDP.LE.0) IDP = 1
2008 * muon neutrinos: temporary (missing index)
2009 * (new patch in projpar: therefore the following this is probably not
2010 * necessary anymore..)
2011 C IF (IDP.EQ.26) IDP = 5
2012 C IF (IDP.EQ.27) IDP = 6
2014 * redefine collision energy
2016 IF (ABS(VAREHI).GT.ZERO) THEN
2018 IF (VARELO.LT.EHADLO) VARELO = EHADLO
2019 CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2021 CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2023 CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2026 1003 FORMAT(1X,'INIT: collision energy not defined!',/,
2027 & 1X,' -program stopped- ')
2031 * switch off evaporation (even if requested) if central coll. requ.
2032 IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2035 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since',
2036 & ' central collisions forced.')
2043 * initialization of evaporation-module
2046 1010 FORMAT(1X,/,'Warning! No evaporation performed since',
2047 & ' evaporation modules not available with this version.')
2057 * save the default JETSET-parameter
2060 * force use of phojet for g-A
2061 IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2062 * initialization of nucleon-nucleon event generator
2063 IF (MCGENE.EQ.2) CALL DT_PHOINI
2064 * initialization of LEPTO event generator
2065 IF (MCGENE.EQ.3) THEN
2067 STOP ' This version does not contain LEPTO !'
2071 * initialization of quasi-elastic neutrino scattering
2072 IF (MCGENE.EQ.4) THEN
2073 IF (IJPROJ.EQ.5) THEN
2075 ELSEIF (IJPROJ.EQ.6) THEN
2077 ELSEIF (IJPROJ.EQ.135) THEN
2079 ELSEIF (IJPROJ.EQ.136) THEN
2081 ELSEIF (IJPROJ.EQ.133) THEN
2083 ELSEIF (IJPROJ.EQ.134) THEN
2088 * normalize fractions of emulsion components
2089 IF (NCOMPO.GT.0) THEN
2092 SUMFRA = SUMFRA+EMUFRA(I)
2094 IF (SUMFRA.GT.ZERO) THEN
2096 EMUFRA(I) = EMUFRA(I)/SUMFRA
2101 * disallow Cronin's multiple scattering for nucleus-nucleus interactions
2102 IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN
2104 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/)
2108 * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2109 C IF (NCOMPO.LE.0) THEN
2110 C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2113 C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2117 * pre-tabulation of elastic cross-sections
2118 CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2124 *********************************************************************
2126 * control card: codewd = STOP *
2128 * stop of the event generation *
2130 * what (1..6) no meaning *
2132 *********************************************************************
2136 9000 FORMAT(1X,'---> unexpected end of input !')
2143 *$ CREATE DT_KKINC.FOR
2146 *===kkinc==============================================================*
2148 SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2151 ************************************************************************
2152 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
2153 * This subroutine is an update of the previous version written *
2154 * by J. Ranft/ H.-J. Moehring. *
2155 * This version dated 19.11.95 is written by S. Roesler *
2156 ************************************************************************
2158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2160 PARAMETER ( LINP = 10 ,
2163 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2164 & TINY2=1.0D-2,TINY3=1.0D-3)
2169 PARAMETER (NMXHKK=200000)
2170 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2171 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2172 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2173 * extended event history
2174 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2175 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2177 * particle properties (BAMJET index convention)
2179 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2180 & IICH(210),IIBAR(210),K1(210),K2(210)
2181 * properties of interacting particles
2182 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2183 * Lorentz-parameters of the current interaction
2184 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2185 & UMO,PPCM,EPROJ,PPROJ
2186 * flags for input different options
2187 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2188 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2189 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2190 * flags for particle decays
2191 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2192 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2193 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2194 * cuts for variable energy runs
2195 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2196 * Glauber formalism: flags and parameters for statistics
2199 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2206 IF (ILOOP.EQ.4) THEN
2207 WRITE(LOUT,1000) NEVHKK
2208 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
2213 * variable energy-runs, recalculate parameters for LT's
2214 IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2217 CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2219 IF (EPN.GT.EPROJ) THEN
2220 WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2221 & ' Requested energy (',EPN,'GeV) exceeds',
2222 & ' initialization energy (',EPROJ,'GeV) !'
2226 * re-initialize /DTPRTA/
2232 IBPROJ = IIBAR(IJPROJ)
2234 * calculate nuclear potentials (common /DTNPOT/)
2235 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2237 * initialize treatment for residual nuclei
2238 CALL DT_RESNCL(EPN,NLOOP,1)
2240 * sample hadron/nucleus-nucleus interaction
2241 CALL DT_KKEVNT(KKMAT,IREJ1)
2242 IF (IREJ1.GT.0) THEN
2243 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2247 IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2249 * intranuclear cascade of final state particles for KTAUGE generations
2251 CALL DT_FOZOCA(LFZC,IREJ1)
2252 IF (IREJ1.GT.0) THEN
2253 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2257 * baryons unable to escape the nuclear potential are treated as
2258 * excited nucleons (ISTHKK=15,16)
2261 * decay of resonances produced in intranuclear cascade processes
2262 **sr 15-11-95 should be obsolete
2263 C IF (LFZC) CALL DT_DECAY1
2266 * treatment of residual nuclei
2267 CALL DT_RESNCL(EPN,NLOOP,2)
2269 * evaporation / fission / fragmentation
2270 * (if intranuclear cascade was sampled only)
2272 CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2273 IF (IREJ1.GT.1) GOTO 101
2274 IF (IREJ1.EQ.1) GOTO 100
2279 * rejection of unphysical configurations
2280 CALL DT_REJUCO(1,IREJ1)
2281 IF (IREJ1.GT.0) THEN
2283 & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2287 * transform finale state into Lab.
2289 CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2290 IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2292 IF (IPI0.EQ.1) CALL DT_DECPI0
2294 C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2302 *$ CREATE DT_DEFAUL.FOR
2305 *===defaul=============================================================*
2307 SUBROUTINE DT_DEFAUL(EPN,PPN)
2309 ************************************************************************
2310 * Variables are set to default values. *
2311 * This version dated 8.5.95 is written by S. Roesler. *
2312 ************************************************************************
2314 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2316 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2317 PARAMETER (TWOPI = 6.283185307179586454D+00)
2319 * particle properties (BAMJET index convention)
2321 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2322 & IICH(210),IIBAR(210),K1(210),K2(210)
2325 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2326 & EBINDP(2),EBINDN(2),EPOT(2,210),
2327 & ETACOU(2),ICOUL,LFERMI
2328 * interface HADRIN-DPM
2329 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2330 * central particle production, impact parameter biasing
2331 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2332 * properties of interacting particles
2333 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2334 * properties of photon/lepton projectiles
2335 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2336 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2337 * emulsion treatment
2338 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2340 * parameter for intranuclear cascade
2342 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2343 * various options for treatment of partons (DTUNUC 1.x)
2344 * (chain recombination, Cronin,..)
2345 LOGICAL LCO2CR,LINTPT
2346 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2348 * threshold values for x-sampling (DTUNUC 1.x)
2349 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2351 * flags for input different options
2352 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2353 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2354 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2355 * n-n cross section fluctuations
2356 PARAMETER (NBINS = 1000)
2357 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2358 * flags for particle decays
2359 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2360 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2361 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2362 * diquark-breaking mechanism
2363 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2364 * nucleon-nucleon event-generator
2367 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2368 * flags for diffractive interactions (DTUNUC 1.x)
2369 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2370 * VDM parameter for photon-nucleus interactions
2371 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2372 * Glauber formalism: flags and parameters for statistics
2375 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2376 * kinematical cuts for lepton-nucleus interactions
2377 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2378 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2379 * flags for activated histograms
2380 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2381 * cuts for variable energy runs
2382 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2383 * parameters for hA-diffraction
2384 COMMON /DTDIHA/ DIBETA,DIALPH
2387 COMMON /LEPTOI/ RPPN,LEPIN,INTER
2388 * steering flags for qel neutrino scattering modules
2389 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2391 COMMON /DTEVNO/ NEVENT,ICASCA
2393 DATA POTMES /0.002D0/
2404 * nucleus independent meson potential
2452 **sr 7.4.98: changed after corrected B-sampling
2471 * definition of soft quark distributions
2476 * cutoff parameters for x-sampling
2522 CMODEL(1) = 'DTUNUC '
2523 CMODEL(2) = 'PHOJET '
2524 CMODEL(3) = 'LEPTO '
2525 CMODEL(4) = 'QNEUTRIN'
2562 IF (ITRSPT.EQ.1) THEN
2597 IF (ITRSPT.EQ.1) THEN
2603 * default Lab.-energy
2605 PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2610 *$ CREATE DT_AAEVT.FOR
2613 *===aaevt==============================================================*
2615 SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2618 ************************************************************************
2619 * This version dated 22.03.96 is written by S. Roesler. *
2620 ************************************************************************
2622 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2624 PARAMETER ( LINP = 10 ,
2628 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2629 * emulsion treatment
2630 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2633 COMMON /DTEVNO/ NEVENT,ICASCA
2635 CHARACTER*8 DATE,HHMMSS
2639 NMSG = MAX(NEVTS/100,1)
2641 * initialization of run-statistics and histograms
2643 CALL PHO_PHIST(1000,DUM)
2645 * initialization of Glauber-formalism
2646 IF (NCOMPO.LE.0) THEN
2647 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2650 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2656 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2657 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2659 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2660 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2661 WRITE(LOUT,1001) DATE,HHMMSS
2662 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2663 & ' Time: ',A8,' )')
2665 * generate NEVTS events
2668 * print run-status message
2669 IF (MOD(IEVT,NMSG).EQ.0) THEN
2671 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2672 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2674 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2675 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2676 WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2677 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2678 & ' Time: ',A,' )',/)
2679 C WRITE(LOUT,1000) IEVT-1
2680 C1000 FORMAT(1X,I8,' events sampled')
2683 * treat nuclear emulsions
2684 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2685 * composite targets only
2688 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2690 CALL PHO_PHIST(2000,DUM)
2694 * print run-statistics and histograms to output-unit 6
2695 CALL PHO_PHIST(3000,DUM)
2701 *$ CREATE DT_LAEVT.FOR
2704 *===laevt==============================================================*
2706 SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2709 ************************************************************************
2710 * Interface to run DPMJET for lepton-nucleus interactions. *
2711 * Kinematics is sampled using the equivalent photon approximation *
2712 * Based on GPHERA-routine by R. Engel. *
2713 * This version dated 23.03.96 is written by S. Roesler. *
2714 ************************************************************************
2716 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2718 PARAMETER ( LINP = 10 ,
2721 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2722 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2723 PARAMETER (TWOPI = 6.283185307179586454D+00,
2725 & ALPHEM = ONE/137.0D0)
2727 C CHARACTER*72 HEADER
2729 * particle properties (BAMJET index convention)
2731 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2732 & IICH(210),IIBAR(210),K1(210),K2(210)
2734 PARAMETER (NMXHKK=200000)
2735 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2736 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2737 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2738 * extended event history
2739 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2740 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2742 * kinematical cuts for lepton-nucleus interactions
2743 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2744 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2745 * properties of interacting particles
2746 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2747 * properties of photon/lepton projectiles
2748 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2749 * kinematics at lepton-gamma vertex
2750 COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2751 * flags for activated histograms
2752 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2753 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2754 * emulsion treatment
2755 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2757 * Glauber formalism: cross sections
2758 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2759 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2760 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2761 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2762 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2763 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2764 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2765 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2766 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2767 & BSLOPE,NEBINI,NQBINI
2768 * nucleon-nucleon event-generator
2771 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2772 * flags for input different options
2773 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2774 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2775 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2777 COMMON /DTEVNO/ NEVENT,ICASCA
2779 DIMENSION XDUMB(40),BGTA(4)
2782 IF (MCGENE.EQ.3) THEN
2783 STOP ' This version does not contain LEPTO !'
2787 NMSG = MAX(NEVTS/10,1)
2789 * mass of incident lepton
2792 IDPPDG = IDT_IPDGHA(IDP)
2794 * consistency of kinematical limits
2795 Q2MIN = MAX(Q2MIN,TINY10)
2796 Q2MAX = MAX(Q2MAX,TINY10)
2797 YMIN = MIN(MAX(YMIN,TINY10),0.999D0)
2798 YMAX = MIN(MAX(YMAX,TINY10),0.999D0)
2800 * total energy of the lepton-nucleon system
2801 PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2802 & +(PLEPT0(3)+PNUCL(3))**2 )
2803 ETOTLN = PLEPT0(4)+PNUCL(4)
2804 ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2805 ECMAX = MIN(ECMAX,ECMLN)
2806 WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2808 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2809 & '------------------',/,9X,'W (min) =',
2810 & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =',
2811 & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2812 & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) ='
2813 & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2814 & F7.4,' for E_lpt >',F7.1,' GeV',/)
2816 * Lorentz-parameter for transf. into Lab
2817 BGTA(1) = PNUCL(1)/AAM(1)
2818 BGTA(2) = PNUCL(2)/AAM(1)
2819 BGTA(3) = PNUCL(3)/AAM(1)
2820 BGTA(4) = PNUCL(4)/AAM(1)
2821 * LT of incident lepton into Lab and dump it in DTEVT1
2822 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2823 & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2824 & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2825 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2826 & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2827 & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2828 * maximum energy of photon nucleon system
2829 PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2830 & +(YMAX*PPL0(3)+PPA(3))**2)
2831 ETOTGN = YMAX*PPL0(4)+PPA(4)
2832 EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2833 EGNMAX = MIN(EGNMAX,ECMAX)
2834 * minimum energy of photon nucleon system
2835 PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2836 & +(YMIN*PPL0(3)+PPA(3))**2)
2837 ETOTGN = YMIN*PPL0(4)+PPA(4)
2838 EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2839 EGNMIN = MAX(EGNMIN,ECMIN)
2841 * limits for Glauber-initialization
2843 Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2844 ECMLI = MAX(EGNMIN,THREE)
2846 WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2847 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1,
2848 & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ',
2849 & 'Glauber-initialization:',/,9X,'W (min) =',F7.1,
2850 & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2851 & ' GeV^2 (max) =',F7.1,' GeV^2',/)
2852 * initialization of Glauber-formalism
2853 IF (NCOMPO.LE.0) THEN
2854 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2857 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2862 * initialization of run-statistics and histograms
2864 CALL PHO_PHIST(1000,DUM)
2866 * maximum photon-nucleus cross section
2870 IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2874 ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2876 IF (EGNMAX.LT.ECMNN(I)) THEN
2879 RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2885 SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2890 IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2894 ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2896 IF (EGNMIN.LT.ECMNN(I)) THEN
2899 RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2905 SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2906 IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2907 SIGMAX = MAX(SIGMAX,SIGXX)
2908 WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2910 * plot photon flux table
2915 ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2916 C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
2918 Y = EXP(AYMIN+ADY*DBLE(I-1))
2919 Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2920 FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2921 & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2922 FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2923 & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2924 C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2927 * maximum residual weight for flux sampling (dy/y)
2929 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2930 WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2931 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2933 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2934 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2935 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2936 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2937 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2938 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
2939 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
2940 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
2941 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
2942 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
2943 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
2944 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
2946 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
2947 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
2948 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
2957 IF (MOD(IEVT,NMSG).EQ.0) THEN
2958 C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
2959 C & STATUS='UNKNOWN')
2960 WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
2971 YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
2972 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2973 Q2LOG = LOG(Q2MAX/Q2LOW)
2974 WGH = (ONE+(ONE-YY)**2)*Q2LOG
2975 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2976 IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
2977 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5)
2978 IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
2981 YEFF = ONE+(ONE-YY)**2
2983 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2984 WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
2985 IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
2988 c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
2989 c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
2991 * kinematics at lepton-photon vertex
2992 * scattered electron
2993 YQ2 = SQRT((ONE-YY)*Q2)
2994 Q2E = Q2/(4.0D0*PLEPT0(4))
2995 E1Y = (ONE-YY)*PLEPT0(4)
2996 CALL DT_DSFECF(SIF,COF)
3001 C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3003 PGAMM(1) = -PLEPT1(1)
3004 PGAMM(2) = -PLEPT1(2)
3005 PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3006 PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3008 PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3009 & +(PGAMM(3)+PNUCL(3))**2 )
3010 ETOTGN = PGAMM(4)+PNUCL(4)
3011 ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3012 IF (ECMGN.LT.0.1D0) GOTO 101
3014 IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3016 * Lorentz-transformation into nucleon-rest system
3017 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3018 & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3019 & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3020 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3021 & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3022 & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3023 * temporary checks..
3024 Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3025 IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3026 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ',
3028 ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3029 IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3030 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ',
3032 YYTMP = PPG(4)/PPL0(4)
3033 IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3034 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ',
3037 * lepton tagger (Lab)
3038 THETA = ACOS( PPL1(3)/PLTOT )
3039 IF (PPL1(4).GT.ELMIN) THEN
3040 IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3042 * photon energy-cut (Lab)
3043 IF (PPG(4).LT.EGMIN) GOTO 101
3044 IF (PPG(4).GT.EGMAX) GOTO 101
3046 XBJ = ABS(Q2/(1.876D0*PPG(4)))
3047 IF (XBJ.LT.XBJMIN) GOTO 101
3050 CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0)
3051 CALL DT_FILHGR( YY,ONE,IHFLY0,NC0)
3052 CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0)
3053 CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3054 CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3056 * rotation angles against z-axis
3058 C SID = SQRT((ONE-COD)*(ONE+COD))
3059 PPT = SQRT(PPG(1)**2+PPG(2)**2)
3063 IF (PGTOT*SID.GT.TINY10) THEN
3064 COF = PPG(1)/(SID*PGTOT)
3065 SIF = PPG(2)/(SID*PGTOT)
3066 ANORF = SQRT(COF*COF+SIF*SIF)
3071 IF (IXSTBL.EQ.0) THEN
3072 * change to photon projectile
3076 * re-initialize LTs with new kinematics
3077 * !!PGAMM ist set in cms (ECMGN) along z
3080 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3083 * get emulsion component if requested
3084 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3085 * convolute with cross section
3086 CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3087 CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3088 IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3089 & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3091 IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3093 CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1)
3094 CALL DT_FILHGR( YY,ONE,IHFLY1,NC1)
3095 CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1)
3096 CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3097 CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3098 * composite targets only
3101 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3103 * rotate momenta of final state particles back in photon-nucleon syst.
3104 DO 4 I=NPOINT(4),NHKK
3105 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3106 & (ISTHKK(I).EQ.1001)) THEN
3110 CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3111 & PHKK(1,I),PHKK(2,I),PHKK(3,I))
3116 CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1)
3117 CALL DT_FILHGR( YY,ONE,IHFLY2,NC1)
3118 CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1)
3119 CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3120 CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3122 * dump this event to histograms
3123 CALL PHO_PHIST(2000,DUM)
3127 WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3128 WGY = WGY*LOG(YMAX/YMIN)
3129 WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3131 C HEADER = ' LAEVT: Q^2 distribution 0'
3132 C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3133 C HEADER = ' LAEVT: Q^2 distribution 1'
3134 C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3135 C HEADER = ' LAEVT: Q^2 distribution 2'
3136 C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3137 C HEADER = ' LAEVT: y distribution 0'
3138 C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3139 C HEADER = ' LAEVT: y distribution 1'
3140 C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3141 C HEADER = ' LAEVT: y distribution 2'
3142 C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3143 C HEADER = ' LAEVT: x distribution 0'
3144 C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3145 C HEADER = ' LAEVT: x distribution 1'
3146 C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3147 C HEADER = ' LAEVT: x distribution 2'
3148 C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3149 C HEADER = ' LAEVT: E_g distribution 0'
3150 C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3151 C HEADER = ' LAEVT: E_g distribution 1'
3152 C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3153 C HEADER = ' LAEVT: E_g distribution 2'
3154 C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3155 C HEADER = ' LAEVT: E_c distribution 0'
3156 C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3157 C HEADER = ' LAEVT: E_c distribution 1'
3158 C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3159 C HEADER = ' LAEVT: E_c distribution 2'
3160 C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3162 * print run-statistics and histograms to output-unit 6
3163 CALL PHO_PHIST(3000,DUM)
3164 IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3169 *$ CREATE DT_DTUINI.FOR
3172 *===dtuini=============================================================*
3174 SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3177 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3180 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3181 * emulsion treatment
3182 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3184 * Glauber formalism: flags and parameters for statistics
3187 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3189 CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3191 CALL PHO_PHIST(1000,DUM)
3192 IF (NCOMPO.LE.0) THEN
3193 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3196 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3199 IF (IOGLB.NE.100) CALL DT_SIGEMU
3205 *$ CREATE DT_DTUOUT.FOR
3208 *===dtuout=============================================================*
3210 SUBROUTINE DT_DTUOUT
3212 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3215 CALL PHO_PHIST(3000,DUM)
3221 *$ CREATE DT_BEAMPR.FOR
3224 *===beampr=============================================================*
3226 SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3228 ************************************************************************
3229 * Initialization of event generation *
3230 * This version dated 7.4.98 is written by S. Roesler. *
3231 ************************************************************************
3233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3236 PARAMETER ( LINP = 10 ,
3239 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3240 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3245 PARAMETER (NMXHKK=200000)
3246 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3247 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3248 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3249 * extended event history
3250 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3251 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3253 * properties of interacting particles
3254 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3255 * particle properties (BAMJET index convention)
3257 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3258 & IICH(210),IIBAR(210),K1(210),K2(210)
3260 COMMON /DTBEAM/ P1(4),P2(4)
3262 C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3263 DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3265 DATA LBEAM /.FALSE./
3272 IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3274 IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3275 PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3276 PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3277 TH = 1.D-6*WHAT(3)/2.D0
3279 P1(1) = PP1*SIN(TH)*COS(PH)
3280 P1(2) = PP1*SIN(TH)*SIN(PH)
3283 P2(1) = PP2*SIN(TH)*COS(PH)
3284 P2(2) = PP2*SIN(TH)*SIN(PH)
3285 P2(3) = -PP2*COS(TH)
3287 ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3288 & -(P1(3)+P2(3))**2 )
3289 ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3290 PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3291 BGX = (P1(1)+P2(1))/ECM
3292 BGY = (P1(2)+P2(2))/ECM
3293 BGZ = (P1(3)+P2(3))/ECM
3294 BGE = (P1(4)+P2(4))/ECM
3295 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3296 & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3297 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3298 & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3299 COD = P1CMS(3)/P1TOT
3300 C SID = SQRT((ONE-COD)*(ONE+COD))
3301 PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3305 IF (P1TOT*SID.GT.TINY10) THEN
3306 COF = P1CMS(1)/(SID*P1TOT)
3307 SIF = P1CMS(2)/(SID*P1TOT)
3308 ANORF = SQRT(COF*COF+SIF*SIF)
3313 C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3314 C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3315 C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3316 C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3320 C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3324 C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3325 C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3326 C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3327 C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3328 C & P1CMS(1),P1CMS(2),P1CMS(3))
3329 C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3330 C & P2CMS(1),P2CMS(2),P2CMS(3))
3331 C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3332 C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3333 C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3334 C & P1TOT,P1(1),P1(2),P1(3),P1(4))
3335 C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3336 C & P2TOT,P2(1),P2(2),P2(3),P2(4))
3337 C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3338 C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3349 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3350 DO 20 I=NPOINT(4),NHKK
3351 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3352 & (ISTHKK(I).EQ.1001)) THEN
3353 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3354 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3356 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3357 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3367 *$ CREATE DT_REJUCO.FOR
3370 *===rejuco=============================================================*
3372 SUBROUTINE DT_REJUCO(MODE,IREJ)
3374 ************************************************************************
3375 * REJection of Unphysical COnfigurations *
3376 * MODE = 1 rejection of particles with unphysically large energy *
3378 * This version dated 27.12.2006 is written by S. Roesler. *
3379 ************************************************************************
3381 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3384 PARAMETER ( LINP = 10 ,
3387 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3388 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3390 * maximum x_cms of final state particle
3391 PARAMETER (XCMSMX = 1.4D0)
3394 PARAMETER (NMXHKK=200000)
3395 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3396 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3397 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3398 * extended event history
3399 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3400 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3402 * Lorentz-parameters of the current interaction
3403 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3404 & UMO,PPCM,EPROJ,PPROJ
3409 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3411 DO 10 I=NPOINT(4),NHKK
3412 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3413 XCMS = ABS(PHKK(4,I))/ECMHLF
3414 IF (XCMS.GT.XCMSMX) GOTO 9999
3425 *$ CREATE DT_EVENTB.FOR
3428 *===eventb=============================================================*
3430 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3432 ************************************************************************
3433 * Treatment of nucleon-nucleon interactions with full two-component *
3434 * Dual Parton Model. *
3435 * NCSY number of nucleon-nucleon interactions *
3436 * IREJ rejection flag *
3437 * This version dated 14.01.2000 is written by S. Roesler *
3438 ************************************************************************
3440 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3442 PARAMETER ( LINP = 10 ,
3445 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3448 PARAMETER (NMXHKK=200000)
3449 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3450 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3451 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3452 * extended event history
3453 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3454 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3456 *! uncomment this line for internal phojet-fragmentation
3457 C #include "dtu_dtevtp.inc"
3458 * particle properties (BAMJET index convention)
3460 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3461 & IICH(210),IIBAR(210),K1(210),K2(210)
3462 * flags for input different options
3463 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3464 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3465 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3467 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3468 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3469 & IREXCI(3),IRDIFF(2),IRINC
3470 * properties of interacting particles
3471 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3472 * properties of photon/lepton projectiles
3473 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3474 * various options for treatment of partons (DTUNUC 1.x)
3475 * (chain recombination, Cronin,..)
3476 LOGICAL LCO2CR,LINTPT
3477 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3480 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3481 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3483 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3484 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3485 * Glauber formalism: collision properties
3486 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3487 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3488 * flags for diffractive interactions (DTUNUC 1.x)
3489 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3490 * statistics: double-Pomeron exchange
3491 COMMON /DTFLG2/ INTFLG,IPOPO
3492 * flags for particle decays
3493 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3494 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3495 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3496 * nucleon-nucleon event-generator
3499 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3500 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3501 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3502 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3503 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3504 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3505 C model switches and parameters
3507 INTEGER ISWMDL,IPAMDL
3508 DOUBLE PRECISION PARMDL
3509 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3510 C initial state parton radiation (internal part)
3511 INTEGER MXISR3,MXISR4
3512 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3513 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3514 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3515 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3516 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3517 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3518 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3519 C event debugging information
3521 PARAMETER (NMAXD=100)
3522 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3523 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3524 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3525 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3526 C general process information
3527 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3528 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3530 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3531 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3532 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3533 & KPRON(15),ISINGL(2000)
3535 * initial values for max. number of phojet scatterings and dtunuc chains
3536 * to be fragmented with one pyexec call
3537 DATA MXPHFR,MXDTFR /10,100/
3540 * pointer to first parton of the first chain in dtevt common
3542 * special flag for double-Pomeron statistics
3544 * counter for low-mass (DTUNUC) interactions
3546 * counter for interactions treated by PHOJET
3549 * scan interactions for single nucleon-nucleon interactions
3550 * (this has to be checked here because Cronin modifies parton momenta)
3552 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3556 MOT = JMOHKK(1,NC+1)
3557 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3558 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3559 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3563 * multiple scattering of chain ends
3564 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3565 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3567 * switch to PHOJET-settings for JETSET parameter
3570 * loop over nucleon-nucleon interaction
3574 * pick up one nucleon-nucleon interaction from DTEVT1
3575 * ppnn / ptnn - momenta of the interacting nucleons (cms)
3576 * ptotnn - total momentum of the interacting nucleons (cms)
3577 * pp1,2 / pt1,2 - momenta of the four partons
3578 * pp / pt - total momenta of the proj / targ partons
3579 * ptot - total momentum of the four partons
3581 MOT = JMOHKK(1,NC+1)
3583 PPNN(K) = PHKK(K,MOP)
3584 PTNN(K) = PHKK(K,MOT)
3585 PTOTNN(K) = PPNN(K)+PTNN(K)
3587 PT1(K) = PHKK(K,NC+1)
3588 PP2(K) = PHKK(K,NC+2)
3589 PT2(K) = PHKK(K,NC+3)
3590 PP(K) = PP1(K)+PP2(K)
3591 PT(K) = PT1(K)+PT2(K)
3592 PTOT(K) = PP(K)+PT(K)
3595 *-----------------------------------------------------------------------
3596 * this is a complete nucleon-nucleon interaction
3598 IF (ISINGL(I).EQ.1) THEN
3600 * initialize PHOJET-variables for remnant/valence-partons
3607 * save current settings of PHOJET process and min. bias flags
3609 KPRON(K) = IPRON(K,1)
3613 * check if forced sampling of diffractive interaction requested
3614 IF (ISINGD.LT.-1) THEN
3618 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3619 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3620 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3623 * for photons: a direct/anomalous interaction is not sampled
3624 * in PHOJET but already in Glauber-formalism. Here we check if such
3625 * an interaction is requested
3626 IF (IJPROJ.EQ.7) THEN
3627 * first switch off direct interactions
3629 * this is a direct interactions
3630 IF (IDIREC.EQ.1) THEN
3635 * this is an anomalous interactions
3636 * (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3637 ELSEIF (IDIREC.EQ.2) THEN
3641 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3644 * make sure that total momenta of partons, pp and pt, are on mass
3645 * shell (Cronin may have srewed this up..)
3646 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3648 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3649 & 'EVENTB: mass shell correction rejected'
3653 * initialize the incoming particles in PHOJET
3654 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3655 CALL PHO_SETPAR(1,22,0,VIRT)
3657 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3659 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3661 * initialize rejection loop counter for anomalous processes
3666 * temporary fix for ifano problem
3670 * generate complete hadron/nucleon/photon-nucleon event with PHOJET
3671 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3673 * for photons: special consistency check for anomalous interactions
3674 IF (IJPROJ.EQ.7) THEN
3675 IF (IRJANO.LT.30) THEN
3676 IF (IFANO(1).NE.0) THEN
3677 * here, an anomalous interaction was generated. Check if it
3678 * was also requested. Otherwise reject this event.
3679 IF (IDIREC.EQ.0) GOTO 800
3681 * here, an anomalous interaction was not generated. Check if it
3682 * was requested in which case we need to reject this event.
3683 IF (IDIREC.EQ.2) GOTO 800
3686 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3687 & IRJANO,IDIREC,NEVHKK
3691 * copy back original settings of PHOJET process and min. bias flags
3693 IPRON(K,1) = KPRON(K)
3697 * check if PHOJET has rejected this event
3698 IF (IREJ1.NE.0) THEN
3699 C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3700 WRITE(LOUT,'(1X,A,I4)')
3701 & 'EVENTB: chain system rejected',IDIREC
3706 * copy partons and strings from PHOJET common back into DTEVT for
3707 * external fragmentation
3710 *! uncomment this line for internal phojet-fragmentation
3711 C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3713 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3714 IF (IREJ1.NE.0) THEN
3716 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3720 * update statistics counter
3721 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3723 *-----------------------------------------------------------------------
3724 * this interaction involves "remnants"
3728 * total mass of this system
3729 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3730 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3731 IF (AMTOT2.LT.ZERO) THEN
3734 AMTOT = SQRT(AMTOT2)
3737 * systems with masses larger than elojet are treated with PHOJET
3738 IF (AMTOT.GT.ELOJET) THEN
3740 * initialize PHOJET-variables for remnant/valence-partons
3741 * projectile parton flavors and valence flag
3742 IHFLD(1,1) = IDHKK(NC)
3743 IHFLD(1,2) = IDHKK(NC+2)
3745 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3746 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3747 * target parton flavors and valence flag
3748 IHFLD(2,1) = IDHKK(NC+1)
3749 IHFLD(2,2) = IDHKK(NC+3)
3751 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3752 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3753 * flag signalizing PHOJET how to treat the remnant:
3754 * iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3755 * iremn > -1 valence remnant: PHOJET assumes flavors according
3756 * to mother particle
3760 * initialize the incoming particles in PHOJET
3761 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3762 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3764 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3766 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3768 * calculate Lorentz parameter of the nucleon-nucleon cm-system
3769 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3770 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3771 BGX = PTOTNN(1)/AMNN
3772 BGY = PTOTNN(2)/AMNN
3773 BGZ = PTOTNN(3)/AMNN
3774 GAM = PTOTNN(4)/AMNN
3775 * transform interacting nucleons into nucleon-nucleon cm-system
3776 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3777 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3778 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3779 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3780 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3781 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3782 * transform (total) momenta of the proj and targ partons into
3783 * nucleon-nucleon cm-system
3784 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3785 & PP(1),PP(2),PP(3),PP(4),
3786 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3787 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3788 & PT(1),PT(2),PT(3),PT(4),
3789 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3790 * energy fractions of the proj and targ partons
3791 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3792 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3795 c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3796 c & (PPTCMS(2)+PTTCMS(2))**2 +
3797 c & (PPTCMS(3)+PTTCMS(3))**2 )
3798 c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3799 c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3800 c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3801 c & (PPSUB(2)+PTSUB(2))**2 +
3802 c & (PPSUB(3)+PTSUB(3))**2 )
3803 c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3804 c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3807 * save current settings of PHOJET process and min. bias flags
3809 KPRON(K) = IPRON(K,1)
3811 * disallow direct photon int. (does not make sense here anyway)
3813 * disallow double pomeron processes (due to technical problems
3814 * in PHOJET, needs to be solved sometime)
3816 * disallow diffraction for sea-diquarks
3817 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3818 & (IABS(IHFLD(1,2)).GT.1100)) THEN
3822 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3823 & (IABS(IHFLD(2,2)).GT.1100)) THEN
3828 * we need massless partons: transform them on mass shell
3835 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3836 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3837 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3838 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3839 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3840 * total energy of the subsysten after mass transformation
3841 * (should be the same as before..)
3842 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3843 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
3845 * after mass shell transformation the x_sub - relation has to be
3846 * corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3848 * The old version was to scale based on the original x_sub and the
3849 * 4-momenta of the subsystem. At very high energy this could lead to
3850 * "pseudo-cm energies" of the parent system considerably exceeding
3851 * the true cm energy. Now we keep the true cm energy and calculate
3852 * new x_sub instead.
3853 C old version PPTCMS(4) = PPSUB(4)/XPSUB
3854 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3855 XPSUB = PPSUB(4)/PPTCMS(4)
3856 IF (IJPROJ.EQ.7) THEN
3857 AMP2 = PHKK(5,MOT)**2
3858 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3861 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3862 & *(PPTCMS(4)+PHKK(5,MOP)))
3863 C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3864 C & *(PPTCMS(4)+PHKK(5,MOT)))
3866 C old version PTTCMS(4) = PTSUB(4)/XTSUB
3867 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3868 XTSUB = PTSUB(4)/PTTCMS(4)
3869 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3870 & *(PTTCMS(4)+PHKK(5,MOT)))
3872 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3873 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3878 * ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
3879 * ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
3880 * pptcms/ pttcms - momenta of the interacting nucleons (cms)
3881 * pp1,2 / pt1,2 - momenta of the four partons
3883 * pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
3884 * ptot - total momentum of the four partons (cms, negl. Fermi)
3885 * ppsub / ptsub - total momenta of the proj / targ partons (cms)
3887 c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3888 c & (PPTCMS(2)+PTTCMS(2))**2 +
3889 c & (PPTCMS(3)+PTTCMS(3))**2 )
3890 c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3891 c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3892 c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3893 c & (PPSUB(2)+PTSUB(2))**2 +
3894 c & (PPSUB(3)+PTSUB(3))**2 )
3895 c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3896 c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3897 c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3898 c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3899 c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3900 c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
3902 c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3903 c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3904 c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3905 c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3906 * transform interacting nucleons into nucleon-nucleon cm-system
3907 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3908 c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3909 c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3910 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3911 c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3912 c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3913 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3914 c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3915 c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3916 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3917 c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3918 c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3919 c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3920 c & (PPNEW2+PTNEW2)**2 +
3921 c & (PPNEW3+PTNEW3)**2 )
3922 c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3923 c & (PPNEW4+PTNEW4+PTSTCM) )
3924 c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3925 c & (PPSUB2+PTSUB2)**2 +
3926 c & (PPSUB3+PTSUB3)**2 )
3927 c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3928 c & (PPSUB4+PTSUB4+PTSTSU) )
3929 C WRITE(*,*) ' mother cmE :'
3930 C WRITE(*,*) ETSTCM,ENEWCM
3931 C WRITE(*,*) ' subsystem cmE :'
3932 C WRITE(*,*) ETSTSU,ENEWSU
3933 C WRITE(*,*) ' projectile mother :'
3934 C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3935 C WRITE(*,*) ' target mother :'
3936 C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3937 C WRITE(*,*) ' projectile subsystem:'
3938 C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3939 C WRITE(*,*) ' target subsystem:'
3940 C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3941 C WRITE(*,*) ' projectile subsystem should be:'
3942 C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3943 C & XPSUB*ETSTCM/2.0D0
3944 C WRITE(*,*) ' target subsystem should be:'
3945 C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3946 C & XTSUB*ETSTCM/2.0D0
3947 C WRITE(*,*) ' subsystem cmE should be: '
3948 C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3951 * generate complete remnant - nucleon/remnant event with PHOJET
3952 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3954 * copy back original settings of PHOJET process flags
3956 IPRON(K,1) = KPRON(K)
3959 * check if PHOJET has rejected this event
3960 IF (IREJ1.NE.0) THEN
3962 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
3964 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3969 * copy partons and strings from PHOJET common back into DTEVT for
3970 * external fragmentation
3973 *! uncomment this line for internal phojet-fragmentation
3974 C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3976 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3977 IF (IREJ1.NE.0) THEN
3978 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3979 & 'EVENTB: chain system rejected 2'
3983 * update statistics counter
3984 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
3986 *-----------------------------------------------------------------------
3987 * two-chain approx. for smaller systems
3992 * special flag for double-Pomeron statistics
3995 * pick up flavors at the ends of the two chains
4000 * ..and the indices of the mothers
4005 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4006 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4008 * check if this chain system was rejected
4009 IF (IREJ1.GT.0) THEN
4010 IF (IOULEV(1).GT.0) THEN
4011 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4012 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4013 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4018 * the following lines are for sea-sea chains rejected in GETCSY
4019 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4020 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4025 * update statistics counter
4026 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4032 *-----------------------------------------------------------------------
4033 * treatment of low-mass chains (if there are any)
4035 IF (NDTUSC.GT.0) THEN
4037 * correct chains of very low masses for possible resonances
4038 IF (IRESCO.EQ.1) THEN
4039 CALL DT_EVTRES(IREJ1)
4040 IF (IREJ1.GT.0) THEN
4041 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4042 IRRES(1) = IRRES(1)+1
4046 * fragmentation of low-mass chains
4047 *! uncomment this line for internal phojet-fragmentation
4048 * (of course it will still be fragmented by DPMJET-routines but it
4049 * has to be done here instead of further below)
4050 C CALL DT_EVTFRA(IREJ1)
4051 C IF (IREJ1.GT.0) THEN
4052 C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4057 *! uncomment this line for internal phojet-fragmentation
4058 C NPOINT(4) = NHKK+1
4059 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4062 *-----------------------------------------------------------------------
4063 * new di-quark breaking mechanisms
4067 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4068 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4073 *-----------------------------------------------------------------------
4074 * hadronize this event
4076 * hadronize PHOJET chain systems
4078 NPJE = NPHOSC/MXPHFR
4079 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4081 NLEFT = NPHOSC-NPJE*MXPHFR
4084 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4085 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4086 IF (IREJ1.GT.0) GOTO 22
4089 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4090 IF (IREJ1.GT.0) GOTO 22
4092 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4094 IF (NLEFT.GT.0) THEN
4095 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4096 IF (IREJ1.GT.0) GOTO 22
4097 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4100 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4101 IF (IREJ1.GT.0) GOTO 22
4102 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4105 * check max. filling level of jetset common and
4106 * reduce mxphfr if necessary
4107 IF (NPYMAX.GT.3000) THEN
4108 IF (NPYMAX.GT.3500) THEN
4109 MXPHFR = MAX(1,MXPHFR-2)
4111 MXPHFR = MAX(1,MXPHFR-1)
4113 C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4116 * hadronize DTUNUC chain systems
4119 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4120 IF (IREJ2.GT.0) GOTO 22
4122 * check max. filling level of jetset common and
4123 * reduce mxdtfr if necessary
4124 IF (NPYMEM.GT.3000) THEN
4125 IF (NPYMEM.GT.3500) THEN
4126 MXDTFR = MAX(1,MXDTFR-20)
4128 MXDTFR = MAX(1,MXDTFR-10)
4130 C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4133 IF (IBACK.EQ.-1) GOTO 23
4136 C CALL DT_EVTFRG(1,IREJ1)
4137 C CALL DT_EVTFRG(2,IREJ2)
4138 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4139 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4144 * get final state particles from /DTEVTP/
4145 *! uncomment this line for internal phojet-fragmentation
4146 C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4149 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4150 C IF (IREJ3.NE.0) GOTO 9999
4160 *$ CREATE DT_GETPJE.FOR
4163 *===getpje=============================================================*
4165 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4167 ************************************************************************
4168 * This subroutine copies PHOJET partons and strings from POEVT1 into *
4170 * MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4171 * PP,PT 4-momenta of projectile/target being handled by *
4173 * This version dated 11.12.99 is written by S. Roesler *
4174 ************************************************************************
4176 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4178 PARAMETER ( LINP = 10 ,
4181 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4182 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4187 PARAMETER (NMXHKK=200000)
4188 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4189 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4190 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4191 * extended event history
4192 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4193 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4195 * Lorentz-parameters of the current interaction
4196 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4197 & UMO,PPCM,EPROJ,PPROJ
4198 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4199 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4200 * flags for input different options
4201 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4202 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4203 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4204 * statistics: double-Pomeron exchange
4205 COMMON /DTFLG2/ INTFLG,IPOPO
4207 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4208 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4211 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4212 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4213 & IREXCI(3),IRDIFF(2),IRINC
4214 C standard particle data interface
4216 PARAMETER (NMXHEP=4000)
4217 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4218 DOUBLE PRECISION PHEP,VHEP
4219 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4220 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4222 C extension to standard particle data interface (PHOJET specific)
4223 INTEGER IMPART,IPHIST,ICOLOR
4224 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4225 C color string configurations including collapsed strings and hadrons
4227 PARAMETER (MSTR=500)
4228 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4229 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4230 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4231 & NNCH(MSTR),IBHAD(MSTR),ISTR
4232 C general process information
4233 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4234 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4235 C model switches and parameters
4237 INTEGER ISWMDL,IPAMDL
4238 DOUBLE PRECISION PARMDL
4239 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4240 C event debugging information
4242 PARAMETER (NMAXD=100)
4243 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4244 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4245 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4246 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4248 DIMENSION PP(4),PT(4)
4258 * store initial momenta for energy-momentum conservation check
4260 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4261 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4263 * copy partons and strings from POEVT1 into DTEVT1
4265 C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4266 IF (NCODE(I).EQ.-99) THEN
4268 IDSTG = IDHEP(IDXSTG)
4275 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4282 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4285 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4288 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4295 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4299 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4301 ELSEIF (NCODE(I).GE.0) THEN
4302 * indices of partons and string in POEVT1
4303 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4304 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4305 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4306 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4307 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4311 * find "mother" string of the string
4312 IDXMS1 = ABS(JMOHEP(1,IDX1))
4313 IDXMS2 = ABS(JMOHEP(1,IDX2))
4314 IF (IDXMS1.NE.IDXMS2) THEN
4317 C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4319 * search POEVT1 for the original hadron of the parton
4324 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4325 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4326 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4327 & (ILOOP.LT.MAXLOP)) GOTO 14
4328 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4333 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4334 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4335 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4337 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4339 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4340 & (ILOOP.LT.MAXLOP)) GOTO 15
4341 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4343 IF (IDXMS1.EQ.1) THEN
4344 ISPTN1 = ISTHKK(MO1)
4348 ISPTN1 = ISTHKK(MO2)
4353 IF (IDXMS2.EQ.1) THEN
4354 ISPTN2 = ISTHKK(MO1)
4358 ISPTN2 = ISTHKK(MO2)
4362 * check for mis-identified mothers and switch mother indices if necessary
4363 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4364 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4366 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4367 ISPTN1 = ISTHKK(MO1)
4370 ISPTN2 = ISTHKK(MO2)
4374 ISPTN1 = ISTHKK(MO2)
4377 ISPTN2 = ISTHKK(MO1)
4382 * register partons in temporary common
4383 * parton at chain end
4388 * flag only partons coming from Pomeron with 41/42
4389 C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4390 IF (IPOM1.NE.0) THEN
4391 ISTX = ABS(ISPTN1)/10
4392 IMO = ABS(ISPTN1)-10*ISTX
4395 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4396 ISTX = ABS(ISPTN1)/10
4397 IMO = ABS(ISPTN1)-10*ISTX
4398 IF ((IDHEP(IDX1).EQ.21).OR.
4399 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4406 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4407 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4409 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4412 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4414 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4417 IHIST(1,NHKK) = IPHIST(1,IDX1)
4420 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4421 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4423 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4424 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4427 NGLUON = IDX2-IDX1-1
4428 IF (NGLUON.GT.0) THEN
4429 DO 17 IGLUON=1,NGLUON
4431 IDXMS = ABS(JMOHEP(1,IDX))
4432 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4436 IDXMS = ABS(JMOHEP(1,IDXMS))
4437 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4438 & (ILOOP.LT.MAXLOP)) GOTO 16
4439 IF (ILOOP.EQ.MAXLOP)
4440 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4442 IF (IDXMS.EQ.1) THEN
4455 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4456 ISTX = ABS(ISPTN)/10
4457 IMO = ABS(ISPTN)-10*ISTX
4458 IF ((IDHEP(IDX).EQ.21).OR.
4459 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4465 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4466 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4468 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4469 & PX,PY,PZ,PE,0,0,0)
4471 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4473 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4474 & PPX,PPY,PPZ,PPE,0,0,0)
4476 IHIST(1,NHKK) = IPHIST(1,IDX)
4479 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4480 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4482 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4483 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4486 * parton at chain end
4491 * flag only partons coming from Pomeron with 41/42
4492 C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4493 IF (IPOM2.NE.0) THEN
4494 ISTX = ABS(ISPTN2)/10
4495 IMO = ABS(ISPTN2)-10*ISTX
4498 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4499 ISTX = ABS(ISPTN2)/10
4500 IMO = ABS(ISPTN2)-10*ISTX
4501 IF ((IDHEP(IDX2).EQ.21).OR.
4502 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4509 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4510 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4512 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4513 & PX,PY,PZ,PE,0,0,0)
4515 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4517 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4518 & PPX,PPY,PPZ,PPE,0,0,0)
4520 IHIST(1,NHKK) = IPHIST(1,IDX2)
4523 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4524 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4526 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4527 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4530 JSTRG = 100*IPROCE+NCODE(I)
4537 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4538 & PX,PY,PZ,PE,0,0,0)
4544 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4547 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4550 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4551 & PPX,PPY,PPZ,PPE,0,0,0)
4557 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4564 VHKK(KK,NHKK) = VHKK(KK,MO2)
4565 WHKK(KK,NHKK) = WHKK(KK,MO1)
4567 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4568 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4572 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4579 IF (UMO.GT.1.0D5) THEN
4584 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4585 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4588 * internal statistics
4589 * dble-Po statistics.
4590 IF (IPROCE.NE.4) IPOPO = 0
4594 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4595 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4597 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4598 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4599 & ') at evt(chain) ',I6,'(',I2,')')
4601 IF (IPROCE.EQ.5) THEN
4602 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4603 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4605 C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4606 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4607 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4609 ELSEIF (IPROCE.EQ.6) THEN
4610 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4611 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4613 C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4615 ELSEIF (IPROCE.EQ.7) THEN
4616 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4617 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4618 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4619 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4620 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4621 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4622 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4623 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4624 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4625 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4627 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4630 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4632 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4633 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4634 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4636 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4637 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4638 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4639 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4640 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4649 *$ CREATE DT_PHOINI.FOR
4652 *===phoini=============================================================*
4654 SUBROUTINE DT_PHOINI
4656 ************************************************************************
4657 * Initialization PHOJET-event generator for nucleon-nucleon interact. *
4658 * This version dated 16.11.95 is written by S. Roesler *
4660 * Last change 27.12.2006 by S. Roesler. *
4661 ************************************************************************
4663 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4665 PARAMETER ( LINP = 10 ,
4668 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4670 * nucleon-nucleon event-generator
4673 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4674 * particle properties (BAMJET index convention)
4676 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4677 & IICH(210),IIBAR(210),K1(210),K2(210)
4678 * Lorentz-parameters of the current interaction
4679 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4680 & UMO,PPCM,EPROJ,PPROJ
4681 * properties of interacting particles
4682 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4683 * properties of photon/lepton projectiles
4684 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4685 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4686 * emulsion treatment
4687 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4689 * VDM parameter for photon-nucleus interactions
4690 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4693 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4694 & EBINDP(2),EBINDN(2),EPOT(2,210),
4695 & ETACOU(2),ICOUL,LFERMI
4696 * Glauber formalism: flags and parameters for statistics
4699 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4701 * parameters for cascade calculations:
4702 * maximum mumber of PDF's which can be defined in phojet (limited
4703 * by the dimension of ipdfs in pho_setpdf)
4704 PARAMETER (MAXPDF = 20)
4705 * PDF parametrization and number of set for the first 30 hadrons in
4706 * the bamjet-code list
4707 * negative numbers mean that the PDF is set in phojet,
4708 * zero stands for "not a hadron"
4709 DIMENSION IPARPD(30),ISETPD(30)
4710 * PDF parametrization
4712 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4713 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4716 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4717 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4720 C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4721 C PARAMETER ( MAXPRO = 16 )
4722 C PARAMETER ( MAXTAB = 20 )
4723 C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4724 C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4726 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4727 C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4729 C global event kinematics and particle IDs
4731 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4732 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4733 C hard cross sections and MC selection weights
4735 PARAMETER ( Max_pro_2 = 16 )
4736 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4738 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4739 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4740 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4741 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4742 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4743 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4744 C model switches and parameters
4746 INTEGER ISWMDL,IPAMDL
4747 DOUBLE PRECISION PARMDL
4748 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4749 C general process information
4750 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4751 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4753 DIMENSION PP(4),PT(4)
4756 DATA LSTART /.TRUE./
4761 * lepton-projectiles: initialize real photon instead
4762 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4766 IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4767 * switch Reggeon off
4770 IFPAP(1) = IDT_IPDGHA(IJP)
4774 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4776 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4777 PVIRT(1) = PMASS(1)**2
4779 IFPAP(2) = IDT_IPDGHA(IJT)
4783 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4785 PMASS(2) = AAM(IFPAB(2))
4791 * get max. possible momenta of incoming particles to be used for PHOJET ini.
4795 IF (UMO.GE.1.E5) THEN
4798 IF (NCOMPO.GT.0) THEN
4801 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4803 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4805 PPFTMP = MAX(PFERMP(1),PFERMN(1))
4806 PTFTMP = MAX(PFERMP(2),PFERMN(2))
4807 IF (PPFTMP.GT.PPF) PPF = PPFTMP
4808 IF (PTFTMP.GT.PTF) PTF = PTFTMP
4811 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4812 PPF = MAX(PFERMP(1),PFERMN(1))
4813 PTF = MAX(PFERMP(2),PFERMN(2))
4819 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4821 PP(4) = SQRT(AMP2+PP(3)**2)
4823 EPF = SQRT(PPF**2+PMASS(1)**2)
4824 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4826 ETF = SQRT(PTF**2+PMASS(2)**2)
4827 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4828 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4829 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4831 WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4833 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
4834 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4835 IF (NCOMPO.GT.0) THEN
4836 WRITE(LOUT,1002) SCPF,PTF,PT
4838 WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4841 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
4842 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4844 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
4845 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4846 WRITE(LOUT,1004) ECMINI
4847 1004 FORMAT(' E_cm = ',E10.3)
4848 IF (IJP.EQ.8) WRITE(LOUT,1005)
4850 & ' DT_PHOINI: warning! proton parameters used for neutron',
4854 * switch off new diffractive cross sections at low energies for nuclei
4855 * (temporary solution)
4856 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4857 WRITE(LOUT,'(1X,A)')
4858 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4859 CALL PHO_SETMDL(30,0,1)
4862 C IF (IJP.EQ.7) THEN
4863 C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4865 C PP(4) = SQRT(AMP2+PP(3)**2)
4868 C IF (IP.GT.1) PFERMX = 0.5D0
4869 C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4870 C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4873 C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4874 C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4875 C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4878 IF ((ISHAD(2).EQ.1).AND.
4879 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4880 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4882 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4887 * patch for cascade calculations:
4888 * define parton distribution functions for other hadrons, i.e. other
4889 * then defined already in phojet
4890 IF (IOGLB.EQ.100) THEN
4892 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4893 & ' assiged (ID,IPAR,ISET)',/)
4896 IF (IPARPD(I).NE.0) THEN
4898 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4899 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4900 IDPDG = IDT_IPDGHA(I)
4903 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4904 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4910 C CALL PHO_PHIST(-1,SIGMAX)
4911 IF (IREJ1.NE.0) THEN
4913 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
4920 *$ CREATE DT_EVENTD.FOR
4923 *===eventd=============================================================*
4925 SUBROUTINE DT_EVENTD(IREJ)
4927 ************************************************************************
4928 * Quasi-elastic neutrino nucleus scattering. *
4929 * This version dated 29.04.00 is written by S. Roesler. *
4930 ************************************************************************
4932 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4934 PARAMETER ( LINP = 10 ,
4937 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4938 PARAMETER (SQTINF=1.0D+15)
4943 PARAMETER (NMXHKK=200000)
4944 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4945 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4946 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4947 * extended event history
4948 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4949 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4951 * flags for input different options
4952 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4953 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4954 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4955 PARAMETER (MAXLND=4000)
4956 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4957 * properties of interacting particles
4958 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4959 * Lorentz-parameters of the current interaction
4960 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4961 & UMO,PPCM,EPROJ,PPROJ
4964 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4965 & EBINDP(2),EBINDN(2),EPOT(2,210),
4966 & ETACOU(2),ICOUL,LFERMI
4967 * steering flags for qel neutrino scattering modules
4968 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4969 COMMON /QNPOL/ POLARX(4),PMODUL
4972 DATA LFIRST /.TRUE./
4984 * interacting target nucleon
4986 IF (NEUDEC.LE.9) THEN
4987 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
4995 RTYP = DT_RNDM(RTYP)
4996 ZFRAC = DBLE(ITZ)/DBLE(IT)
4997 IF (RTYP.LE.ZFRAC) THEN
5006 * select first nucleon in list with matching id and reset all other
5007 * nucleons which have been marked as "wounded" by ININUC
5010 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5015 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5019 & STOP ' EVENTD: interacting target nucleon not found! '
5021 * correct position of proj. lepton: assume position of target nucleon
5023 VHKK(I,1) = VHKK(I,IDX)
5024 WHKK(I,1) = WHKK(I,IDX)
5027 * load initial momenta for conservation check
5029 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5030 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5034 * quasi-elastic scattering
5035 IF (NEUDEC.LT.9) THEN
5036 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5037 & PHKK(4,IDX),PHKK(5,IDX))
5038 * CC event on p or n
5039 ELSEIF (NEUDEC.EQ.10) THEN
5040 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5041 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5042 * NC event on p or n
5043 ELSEIF (NEUDEC.EQ.11) THEN
5044 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5045 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5048 * get final state particles from Lund-common and write them into HKKEVT
5054 IF (K(I,1).EQ.1) THEN
5060 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5061 IDBJ = IDT_ICIHAD(ID)
5062 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5063 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5064 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5066 VHKK(1,NHKK) = VHKK(1,IDX)
5067 VHKK(2,NHKK) = VHKK(2,IDX)
5068 VHKK(3,NHKK) = VHKK(3,IDX)
5069 VHKK(4,NHKK) = VHKK(4,IDX)
5071 C WHKK(1,NHKK) = POLARX(1)
5072 C WHKK(2,NHKK) = POLARX(2)
5073 C WHKK(3,NHKK) = POLARX(3)
5074 C WHKK(4,NHKK) = POLARX(4)
5076 WHKK(1,NHKK) = WHKK(1,IDX)
5077 WHKK(2,NHKK) = WHKK(2,IDX)
5078 WHKK(3,NHKK) = WHKK(3,IDX)
5079 WHKK(4,NHKK) = WHKK(4,IDX)
5081 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5087 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5088 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5091 * transform momenta into cms (as required for inc etc.)
5093 IF (ISTHKK(I).EQ.1) THEN
5094 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5103 *$ CREATE DT_KKEVNT.FOR
5106 *===kkevnt=============================================================*
5108 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5110 ************************************************************************
5111 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5112 * without nuclear effects (one event). *
5113 * This subroutine is an update of the previous version (KKEVT) written *
5114 * by J. Ranft/ H.-J. Moehring. *
5115 * This version dated 20.04.95 is written by S. Roesler *
5116 ************************************************************************
5118 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5120 PARAMETER ( LINP = 10 ,
5123 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5125 PARAMETER ( MAXNCL = 260,
5127 & MAXSQU = 20*MAXVQU,
5128 & MAXINT = MAXVQU+MAXSQU)
5130 PARAMETER (NMXHKK=200000)
5131 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5132 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5133 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5134 * extended event history
5135 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5136 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5138 * flags for input different options
5139 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5140 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5141 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5143 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5144 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5145 & IREXCI(3),IRDIFF(2),IRINC
5147 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5148 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5150 * properties of interacting particles
5151 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5152 * Lorentz-parameters of the current interaction
5153 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5154 & UMO,PPCM,EPROJ,PPROJ
5155 * flags for diffractive interactions (DTUNUC 1.x)
5156 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5157 * interface HADRIN-DPM
5158 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5159 * nucleon-nucleon event-generator
5162 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5163 * coordinates of nucleons
5164 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5165 * interface between Glauber formalism and DPM
5166 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5167 & INTER1(MAXINT),INTER2(MAXINT)
5168 * Glauber formalism: collision properties
5169 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5170 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5171 * central particle production, impact parameter biasing
5172 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5174 * statistics: Glauber-formalism
5175 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5178 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5187 IF (MOD(NC,10).EQ.0) THEN
5188 WRITE(LOUT,1000) NEVHKK
5189 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5193 * initialize DTEVT1/DTEVT2
5196 * We need the following only in order to sample nucleon coordinates.
5197 * However we don't have parameters (cross sections, slope etc.)
5198 * for neutrinos available. Therefore switch projectile to proton
5200 IF (MCGENE.EQ.4) THEN
5207 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5208 * make sure that Glauber-formalism is called each time the interaction
5209 * configuration changed
5210 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5211 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5212 * sample number of nucleon-nucleon coll. according to Glauber-form.
5213 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5224 * force diffractive particle production in h-K interactions
5225 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5226 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5231 * check number of involved proj. nucl. (NP) if central prod.is requested
5232 IF (ICENTR.GT.0) THEN
5233 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5234 IF (IBACK.GT.0) GOTO 10
5237 * get initial nucleon-configuration in projectile and target
5238 * rest-system (including Fermi-momenta if requested)
5239 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5241 IF (EPROJ.LE.EHADTH) MODE = 3
5242 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5244 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5246 * activate HADRIN at low energies (implemented for h-N scattering only)
5247 IF (EPROJ.LE.EHADHI) THEN
5248 IF (EHADTH.LT.ZERO) THEN
5249 * smooth transition btwn. DPM and HADRIN
5250 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5252 IF (RR.GT.FRAC) THEN
5254 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5255 IF (IREJ1.GT.0) GOTO 1
5258 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5262 * fixed threshold for onset of production via HADRIN
5263 IF (EPROJ.LE.EHADTH) THEN
5265 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5266 IF (IREJ1.GT.0) GOTO 1
5269 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5274 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5275 & I3,') with target (m=',I3,')',/,11X,
5276 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5277 & 'GeV) cannot be handled')
5279 * sampling of momentum-x fractions & flavors of chain ends
5282 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5285 * collect momenta of chain ends and put them into DTEVT1
5286 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5287 IF (IREJ1.NE.0) GOTO 1
5291 * handle chains including fragmentation (two-chain approximation)
5292 IF (MCGENE.EQ.1) THEN
5293 * two-chain approximation
5294 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5295 IF (IREJ1.NE.0) THEN
5296 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5299 ELSEIF (MCGENE.EQ.2) THEN
5300 * multiple-Po exchange including minijets
5301 CALL DT_EVENTB(NCSY,IREJ1)
5302 IF (IREJ1.NE.0) THEN
5303 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5306 ELSEIF (MCGENE.EQ.3) THEN
5307 STOP ' This version does not contain LEPTO !'
5308 ELSEIF (MCGENE.EQ.4) THEN
5309 * quasi-elastic neutrino scattering
5310 CALL DT_EVENTD(IREJ1)
5311 IF (IREJ1.NE.0) THEN
5312 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5316 WRITE(LOUT,1002) MCGENE
5317 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5318 & ' not available - program stopped')
5329 *$ CREATE DT_CHKCEN.FOR
5332 *===chkcen=============================================================*
5334 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5336 ************************************************************************
5337 * Check of number of involved projectile nucleons if central production*
5339 * Adopted from a part of the old KKEVT routine which was written by *
5340 * J. Ranft/H.-J.Moehring. *
5341 * This version dated 13.01.95 is written by S. Roesler *
5342 ************************************************************************
5344 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5346 PARAMETER ( LINP = 10 ,
5351 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5352 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5354 * central particle production, impact parameter biasing
5355 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5360 IF (ICENTR.EQ.2) THEN
5363 IF (NP.LT.IP-1) IBACK = 1
5364 ELSEIF (IP.LE.16) THEN
5365 IF (NP.LT.IP-2) IBACK = 1
5366 ELSEIF (IP.LE.32) THEN
5367 IF (NP.LT.IP-3) IBACK = 1
5368 ELSEIF (IP.GE.33) THEN
5369 IF (NP.LT.IP-5) IBACK = 1
5371 ELSEIF (IP.EQ.IT) THEN
5373 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5375 IF (NP.LT.IP-IP/8) IBACK = 1
5377 ELSEIF (ABS(IP-IT).LT.3) THEN
5378 IF (NP.LT.IP-IP/8) IBACK = 1
5381 * new version (DPMJET, 5.6.99)
5384 IF (NP.LT.IP-1) IBACK = 1
5385 ELSEIF (IP.LE.16) THEN
5386 IF (NP.LT.IP-2) IBACK = 1
5387 ELSEIF (IP.LT.32) THEN
5388 IF (NP.LT.IP-3) IBACK = 1
5389 ELSEIF (IP.GE.32) THEN
5392 IF (NP.LT.IP-1) IBACK = 1
5395 IF (NP.LT.IP) IBACK = 1
5398 ELSEIF (IP.EQ.IT) THEN
5401 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5404 IF (NP.LT.IP-IP/4) IBACK = 1
5406 ELSEIF (ABS(IP-IT).LT.3) THEN
5407 IF (NP.LT.IP-IP/8) IBACK = 1
5416 *$ CREATE DT_ININUC.FOR
5419 *===ininuc=============================================================*
5421 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5423 ************************************************************************
5424 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5425 * including Fermi-momenta (if reqested). *
5426 * ID BAMJET-code for hadrons (instead of nuclei) *
5427 * NMASS mass number of nucleus (number of nucleons) *
5428 * NCH charge of nucleus *
5429 * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5430 * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5431 * IMODE = 1 projectile nucleus *
5432 * = 2 target nucleus *
5433 * = 3 target nucleus (E_lab<E_thr for HADRIN) *
5434 * Adopted from a part of the old KKEVT routine which was written by *
5435 * J. Ranft/H.-J.Moehring. *
5436 * This version dated 13.01.95 is written by S. Roesler *
5437 ************************************************************************
5439 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5441 PARAMETER ( LINP = 10 ,
5444 PARAMETER (FM2MM=1.0D-12)
5446 PARAMETER ( MAXNCL = 260,
5448 & MAXSQU = 20*MAXVQU,
5449 & MAXINT = MAXVQU+MAXSQU)
5451 PARAMETER (NMXHKK=200000)
5452 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5453 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5454 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5455 * extended event history
5456 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5457 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5459 * flags for input different options
5460 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5461 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5462 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5463 * auxiliary common for chain system storage (DTUNUC 1.x)
5464 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5467 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5468 & EBINDP(2),EBINDN(2),EPOT(2,210),
5469 & ETACOU(2),ICOUL,LFERMI
5470 * properties of photon/lepton projectiles
5471 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5472 * particle properties (BAMJET index convention)
5474 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5475 & IICH(210),IIBAR(210),K1(210),K2(210)
5476 * Glauber formalism: collision properties
5477 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5478 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5479 * flavors of partons (DTUNUC 1.x)
5480 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5481 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5482 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5483 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5484 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5485 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5486 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5487 * interface HADRIN-DPM
5488 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5490 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5492 * number of neutrons
5501 IF (IMODE.GT.2) MODE = 2
5502 **sr 29.5. new NPOINT(1)-definition
5503 C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5508 * get initial configuration
5511 IF (JS(I).GT.0) THEN
5512 ISTHKK(NHKK) = 10+MODE
5513 IF (IMODE.EQ.3) THEN
5514 * additional treatment if HADRIN-generator is requested
5516 IF (NHADRI.EQ.1) IDXTA = NHKK
5517 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5520 ISTHKK(NHKK) = 12+MODE
5522 IF (NMASS.GE.2) THEN
5523 * treatment for nuclei
5524 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5526 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5529 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5532 ELSEIF (NN.LT.NNEU) THEN
5535 ELSEIF (NP.LT.NCH) THEN
5539 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5550 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5553 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5555 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5557 PFTOT(K) = PFTOT(K)+PF(K)
5558 PHKK(K,NHKK) = PF(K)
5560 PHKK(5,NHKK) = AAM(IDX)
5562 * treatment for hadrons
5563 IDHKK(NHKK) = IDT_IPDGHA(ID)
5565 PHKK(4,NHKK) = AAM(ID)
5566 PHKK(5,NHKK) = AAM(ID)
5568 C IF (IDHKK(NHKK).EQ.22) THEN
5569 C PHKK(4,NHKK) = AAM(33)
5570 C PHKK(5,NHKK) = AAM(33)
5575 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5582 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5583 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5585 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5586 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5587 VHKK(4,NHKK) = 0.0D0
5588 WHKK(4,NHKK) = 0.0D0
5591 * balance Fermi-momenta
5592 IF (NMASS.GE.2) THEN
5596 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5598 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5599 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5606 *$ CREATE DT_FER4M.FOR
5609 *===fer4m==============================================================*
5611 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5613 ************************************************************************
5614 * Sampling of nucleon Fermi-momenta from distributions at T=0. *
5615 * processed by S. Roesler, 17.10.95 *
5616 ************************************************************************
5618 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5620 PARAMETER ( LINP = 10 ,
5626 * particle properties (BAMJET index convention)
5628 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5629 & IICH(210),IIBAR(210),K1(210),K2(210)
5632 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5633 & EBINDP(2),EBINDN(2),EPOT(2,210),
5634 & ETACOU(2),ICOUL,LFERMI
5636 DATA LSTART /.TRUE./
5642 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
5646 CALL DT_DFERMI(PABS)
5648 C IF (PABS.GE.PBIND) THEN
5650 C IF (MOD(ILOOP,500).EQ.0) THEN
5651 C WRITE(LOUT,1001) PABS,PBIND,ILOOP
5652 C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
5653 C & ' energy ',2E12.3,I6)
5657 CALL DT_DPOLI(POLC,POLS)
5658 CALL DT_DSFECF(SFE,CFE)
5662 ET = SQRT(PABS*PABS+AAM(KT)**2)
5676 *$ CREATE DT_NUC2CM.FOR
5679 *===nuc2cm=============================================================*
5681 SUBROUTINE DT_NUC2CM
5683 ************************************************************************
5684 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
5685 * nucl. cms. (This subroutine replaces NUCMOM.) *
5686 * This version dated 15.01.95 is written by S. Roesler *
5687 ************************************************************************
5689 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5691 PARAMETER ( LINP = 10 ,
5694 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5697 PARAMETER (NMXHKK=200000)
5698 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5699 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5700 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5701 * extended event history
5702 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5703 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5706 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5707 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5709 * properties of photon/lepton projectiles
5710 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5711 * particle properties (BAMJET index convention)
5713 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5714 & IICH(210),IIBAR(210),K1(210),K2(210)
5715 * Glauber formalism: collision properties
5716 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5717 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5719 * statistics: Glauber-formalism
5720 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5732 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5733 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5734 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5736 C IF (IDHKK(I).EQ.22) THEN
5744 C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5745 C & PX,PY,PZ,PE,IDB,MODE)
5746 IF (PHKK(5,I).GT.ZERO) THEN
5747 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5748 & PX,PY,PZ,PE,IDBAM(I),MODE)
5758 C IF (ID.EQ.22) ID = 113
5759 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5760 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5761 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5765 NWTACC = MAX(NWAACC,NWBACC)
5769 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5777 *$ CREATE DT_SPLPTN.FOR
5780 *===splptn=============================================================*
5782 SUBROUTINE DT_SPLPTN(NN)
5784 ************************************************************************
5785 * SamPLing of ParToN momenta and flavors. *
5786 * This version dated 15.01.95 is written by S. Roesler *
5787 ************************************************************************
5789 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5791 PARAMETER ( LINP = 10 ,
5795 * Lorentz-parameters of the current interaction
5796 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5797 & UMO,PPCM,EPROJ,PPROJ
5799 * sample flavors of sea-quarks
5800 CALL DT_SPLFLA(NN,1)
5802 * sample x-values of partons at chain ends
5804 CALL DT_XKSAMP(NN,ECM)
5807 CALL DT_SPLFLA(NN,2)
5812 *$ CREATE DT_SPLFLA.FOR
5815 *===splfla=============================================================*
5817 SUBROUTINE DT_SPLFLA(NN,MODE)
5819 ************************************************************************
5820 * SamPLing of FLAvors of partons at chain ends. *
5821 * This subroutine replaces FLKSAA/FLKSAM. *
5822 * NN number of nucleon-nucleon interactions *
5823 * MODE = 1 sea-flavors *
5824 * = 2 valence-flavors *
5825 * Based on the original version written by J. Ranft/H.-J. Moehring. *
5826 * This version dated 16.01.95 is written by S. Roesler *
5827 ************************************************************************
5829 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5831 PARAMETER ( LINP = 10 ,
5835 PARAMETER ( MAXNCL = 260,
5837 & MAXSQU = 20*MAXVQU,
5838 & MAXINT = MAXVQU+MAXSQU)
5839 * flavors of partons (DTUNUC 1.x)
5840 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5841 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5842 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5843 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5844 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5845 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5846 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5847 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5848 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5849 & IXPV,IXPS,IXTV,IXTS,
5850 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5851 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5852 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5853 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5854 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5855 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5856 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5857 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5858 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5859 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5860 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5861 * particle properties (BAMJET index convention)
5863 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5864 & IICH(210),IIBAR(210),K1(210),K2(210)
5865 * various options for treatment of partons (DTUNUC 1.x)
5866 * (chain recombination, Cronin,..)
5867 LOGICAL LCO2CR,LINTPT
5868 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5874 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5878 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5881 ELSEIF (MODE.EQ.2) THEN
5884 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5887 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5894 *$ CREATE DT_GETPTN.FOR
5897 *===getptn=============================================================*
5899 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5901 ************************************************************************
5902 * This subroutine collects partons at chain ends from temporary *
5903 * commons and puts them into DTEVT1. *
5904 * This version dated 15.01.95 is written by S. Roesler *
5905 ************************************************************************
5907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5909 PARAMETER ( LINP = 10 ,
5912 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5916 PARAMETER ( MAXNCL = 260,
5918 & MAXSQU = 20*MAXVQU,
5919 & MAXINT = MAXVQU+MAXSQU)
5921 PARAMETER (NMXHKK=200000)
5922 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5923 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5924 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5925 * extended event history
5926 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5927 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5929 * flags for input different options
5930 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5931 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5932 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5933 * auxiliary common for chain system storage (DTUNUC 1.x)
5934 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5936 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5937 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5939 * flags for diffractive interactions (DTUNUC 1.x)
5940 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5941 * x-values of partons (DTUNUC 1.x)
5942 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5943 & XTVQ(MAXVQU),XTVD(MAXVQU),
5944 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
5945 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
5946 * flavors of partons (DTUNUC 1.x)
5947 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5948 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5949 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5950 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5951 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5952 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5953 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5954 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5955 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5956 & IXPV,IXPS,IXTV,IXTS,
5957 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5958 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5959 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5960 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5961 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5962 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5963 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5964 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5965 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5966 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5967 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5969 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
5971 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
5979 IF (ISKPCH(1,I).EQ.99) GOTO 10
5980 ICCHAI(1,1) = ICCHAI(1,1)+2
5983 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
5984 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
5986 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
5987 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
5988 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
5989 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
5991 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
5992 & +(PP1(3)+PT1(3))**2)
5994 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
5995 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
5996 & +(PP2(3)+PT2(3))**2)
5998 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
5999 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6002 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6003 C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6004 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6007 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6009 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6010 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6011 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6012 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6013 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6015 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6017 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6019 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6026 IF (ISKPCH(2,I).EQ.99) GOTO 20
6027 ICCHAI(1,2) = ICCHAI(1,2)+2
6030 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6031 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6033 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6034 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6035 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6036 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6038 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6039 & +(PP1(3)+PT1(3))**2)
6041 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6042 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6043 & +(PP2(3)+PT2(3))**2)
6045 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6046 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6049 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6050 C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6051 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6054 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6056 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6057 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6058 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6059 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6060 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6062 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6064 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6066 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6073 IF (ISKPCH(3,I).EQ.99) GOTO 30
6074 ICCHAI(1,3) = ICCHAI(1,3)+2
6077 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6078 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6080 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6081 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6082 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6083 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6085 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6086 & +(PP1(3)+PT1(3))**2)
6088 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6089 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6090 & +(PP2(3)+PT2(3))**2)
6092 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6093 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6096 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6097 C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6098 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6101 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6103 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6104 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6105 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6106 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6107 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6109 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6111 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6113 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6118 * disea-valence chains
6120 IF (ISKPCH(5,I).EQ.99) GOTO 50
6121 ICCHAI(1,5) = ICCHAI(1,5)+2
6124 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6125 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6127 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6128 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6129 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6130 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6132 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6133 & +(PP1(3)+PT1(3))**2)
6135 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6136 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6137 & +(PP2(3)+PT2(3))**2)
6139 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6140 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6143 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6144 C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6145 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6148 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6150 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6151 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6152 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6153 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6154 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6156 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6158 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6160 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6165 * valence-sea chains
6167 IF (ISKPCH(6,I).EQ.99) GOTO 60
6168 ICCHAI(1,6) = ICCHAI(1,6)+2
6171 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6172 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6174 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6175 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6176 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6177 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6179 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6180 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6181 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6182 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6183 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6185 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6187 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6189 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6191 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6193 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6194 & +(PP1(3)+PT1(3))**2)
6196 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6197 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6198 & +(PP2(3)+PT2(3))**2)
6200 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6202 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6204 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6206 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6208 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6210 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6211 & +(PP1(3)+PT2(3))**2)
6213 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6214 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6215 & +(PP2(3)+PT1(3))**2)
6217 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6219 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6222 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6223 C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6224 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6227 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6232 * sea-valence chains
6234 IF (ISKPCH(4,I).EQ.99) GOTO 40
6235 ICCHAI(1,4) = ICCHAI(1,4)+2
6238 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6239 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6241 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6242 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6243 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6244 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6246 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6247 & +(PP1(3)+PT1(3))**2)
6249 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6250 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6251 & +(PP2(3)+PT2(3))**2)
6253 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6254 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6257 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6258 C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6259 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6262 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6264 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6265 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6266 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6267 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6268 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6270 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6272 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6274 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6279 * valence-disea chains
6281 IF (ISKPCH(7,I).EQ.99) GOTO 70
6282 ICCHAI(1,7) = ICCHAI(1,7)+2
6285 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6286 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6288 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6289 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6290 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6291 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6293 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6294 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6295 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6296 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6297 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6299 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6301 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6303 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6305 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6307 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6308 & +(PP1(3)+PT1(3))**2)
6310 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6311 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6312 & +(PP2(3)+PT2(3))**2)
6314 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6316 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6318 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6320 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6322 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6324 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6325 & +(PP1(3)+PT2(3))**2)
6327 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6328 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6329 & +(PP2(3)+PT1(3))**2)
6331 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6333 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6336 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6337 C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6338 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6341 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6346 * valence-valence chains
6348 IF (ISKPCH(8,I).EQ.99) GOTO 80
6349 ICCHAI(1,8) = ICCHAI(1,8)+2
6352 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6353 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6355 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6356 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6357 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6358 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6360 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6361 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6362 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6363 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6365 * check for diffractive event
6367 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6368 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6370 PP(K) = PP1(K)+PP2(K)
6371 PT(K) = PT1(K)+PT2(K)
6374 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6375 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6376 C IF (IREJ1.NE.0) GOTO 9999
6377 IF (IREJ1.NE.0) THEN
6385 IF (IDIFF.EQ.0) THEN
6386 * valence-valence chain system
6387 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6390 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6391 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6392 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6393 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6394 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6395 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6396 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6397 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6398 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6399 & +(PP1(3)+PT1(3))**2)
6401 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6402 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6403 & +(PP2(3)+PT2(3))**2)
6405 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6408 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6409 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6410 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6411 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6412 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6413 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6414 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6415 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6416 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6417 & +(PP1(3)+PT2(3))**2)
6419 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6420 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6421 & +(PP2(3)+PT1(3))**2)
6423 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6425 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6428 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6429 C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6430 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6433 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6438 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6440 * energy-momentum & flavor conservation check
6441 IF (ABS(IDIFF).NE.1) THEN
6442 IF (IDIFF.NE.0) THEN
6443 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6446 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6462 *$ CREATE DT_CHKCSY.FOR
6465 *===chkcsy=============================================================*
6467 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6469 ************************************************************************
6470 * CHeCk Chain SYstem for consistency of partons at chain ends. *
6471 * ID1,ID2 PDG-numbers of partons at chain ends *
6472 * LCHK = .true. consistent chain *
6473 * = .false. inconsistent chain *
6474 * This version dated 18.01.95 is written by S. Roesler *
6475 ************************************************************************
6477 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6479 PARAMETER ( LINP = 10 ,
6488 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6489 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6490 * q-qq, aq-aqaq chain
6491 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6492 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6493 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6495 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6496 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6502 *$ CREATE DT_EVENTA.FOR
6505 *===eventa=============================================================*
6507 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6509 ************************************************************************
6510 * Treatment of nucleon-nucleon interactions in a two-chain *
6512 * (input) ID BAMJET-index of projectile hadron (in case of *
6514 * IP/IT mass number of projectile/target nucleus *
6515 * NCSY number of two chain systems *
6516 * IREJ rejection flag *
6517 * This version dated 15.01.95 is written by S. Roesler *
6518 ************************************************************************
6520 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6522 PARAMETER ( LINP = 10 ,
6525 PARAMETER (TINY10=1.0D-10)
6528 PARAMETER (NMXHKK=200000)
6529 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6530 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6531 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6532 * extended event history
6533 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6534 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6537 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6538 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6539 & IREXCI(3),IRDIFF(2),IRINC
6540 * flags for diffractive interactions (DTUNUC 1.x)
6541 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6542 * particle properties (BAMJET index convention)
6544 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6545 & IICH(210),IIBAR(210),K1(210),K2(210)
6546 * flags for input different options
6547 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6548 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6549 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6550 * various options for treatment of partons (DTUNUC 1.x)
6551 * (chain recombination, Cronin,..)
6552 LOGICAL LCO2CR,LINTPT
6553 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6556 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6561 * skip following treatment for low-mass diffraction
6562 IF (ABS(IFLAGD).EQ.1) THEN
6563 NPOINT(3) = NPOINT(2)
6567 * multiple scattering of chain ends
6568 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6569 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6572 * get a two-chain system from DTEVT1
6580 PT1(K) = PHKK(K,NC+1)
6581 PP2(K) = PHKK(K,NC+2)
6582 PT2(K) = PHKK(K,NC+3)
6588 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6589 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6590 IF (IREJ1.GT.0) THEN
6592 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6598 * meson/antibaryon projectile:
6599 * sample single-chain valence-valence systems (Reggeon contrib.)
6600 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6601 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6604 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6605 * check DTEVT1 for remaining resonance mass corrections
6606 CALL DT_EVTRES(IREJ1)
6607 IF (IREJ1.GT.0) THEN
6608 IRRES(1) = IRRES(1)+1
6609 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6614 * assign p_t to two-"chain" systems consisting of two resonances only
6615 * since only entries for chains will be affected, this is obsolete
6616 * in case of JETSET-fragmetation
6619 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6620 IF (LCO2CR) CALL DT_COM2CR
6624 * fragmentation of the complete event
6625 **uncomment for internal phojet-fragmentation
6626 C CALL DT_EVTFRA(IREJ1)
6627 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6628 IF (IREJ1.GT.0) THEN
6630 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6634 * decay of possible resonances (should be obsolete)
6645 *$ CREATE DT_GETCSY.FOR
6648 *===getcsy=============================================================*
6650 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6651 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6653 ************************************************************************
6654 * This version dated 15.01.95 is written by S. Roesler *
6655 ************************************************************************
6657 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6659 PARAMETER ( LINP = 10 ,
6662 PARAMETER (TINY10=1.0D-10)
6665 PARAMETER (NMXHKK=200000)
6666 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6667 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6668 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6669 * extended event history
6670 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6671 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6674 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6675 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6676 & IREXCI(3),IRDIFF(2),IRINC
6677 * flags for input different options
6678 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6679 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6680 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6681 * flags for diffractive interactions (DTUNUC 1.x)
6682 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6684 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6685 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6689 * get quark content of partons
6696 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6697 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6698 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6699 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6700 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6701 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6702 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6703 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6705 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6707 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6708 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6710 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6711 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6713 * store initial configuration for energy-momentum cons. check
6714 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6716 * sample intrinsic p_t at chain-ends
6717 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6718 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6719 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6720 IF (IREJ1.NE.0) THEN
6721 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6726 C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6727 C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6728 C* check second chain for resonance
6729 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6730 C & AMCH2,AMCH2N,IDCH2,IREJ1)
6731 C IF (IREJ1.NE.0) GOTO 9999
6732 C IF (IDR2.NE.0) THEN
6733 C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6734 C & AMCH2,AMCH2N,AMCH1,IREJ1)
6735 C IF (IREJ1.NE.0) GOTO 9999
6737 C* check first chain for resonance
6738 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6739 C & AMCH1,AMCH1N,IDCH1,IREJ1)
6740 C IF (IREJ1.NE.0) GOTO 9999
6741 C IF (IDR1.NE.0) IDR1 = 100*IDR1
6743 C* check first chain for resonance
6744 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6745 C & AMCH1,AMCH1N,IDCH1,IREJ1)
6746 C IF (IREJ1.NE.0) GOTO 9999
6747 C IF (IDR1.NE.0) THEN
6748 C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6749 C & AMCH1,AMCH1N,AMCH2,IREJ1)
6750 C IF (IREJ1.NE.0) GOTO 9999
6752 C* check second chain for resonance
6753 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6754 C & AMCH2,AMCH2N,IDCH2,IREJ1)
6755 C IF (IREJ1.NE.0) GOTO 9999
6756 C IF (IDR2.NE.0) IDR2 = 100*IDR2
6760 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6761 * check chains for resonances
6762 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6763 & AMCH1,AMCH1N,IDCH1,IREJ1)
6764 IF (IREJ1.NE.0) GOTO 9999
6765 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6766 & AMCH2,AMCH2N,IDCH2,IREJ1)
6767 IF (IREJ1.NE.0) GOTO 9999
6768 * change kinematics corresponding to resonance-masses
6769 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6770 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6771 & AMCH1,AMCH1N,AMCH2,IREJ1)
6772 IF (IREJ1.GT.0) GOTO 9999
6773 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6774 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6775 & AMCH2,AMCH2N,IDCH2,IREJ1)
6776 IF (IREJ1.NE.0) GOTO 9999
6777 IF (IDR2.NE.0) IDR2 = 100*IDR2
6778 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6779 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6780 & AMCH2,AMCH2N,AMCH1,IREJ1)
6781 IF (IREJ1.GT.0) GOTO 9999
6782 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6783 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6784 & AMCH1,AMCH1N,IDCH1,IREJ1)
6785 IF (IREJ1.NE.0) GOTO 9999
6786 IF (IDR1.NE.0) IDR1 = 100*IDR1
6787 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6788 AMDIF1 = ABS(AMCH1-AMCH1N)
6789 AMDIF2 = ABS(AMCH2-AMCH2N)
6790 IF (AMDIF2.LT.AMDIF1) THEN
6791 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6792 & AMCH2,AMCH2N,AMCH1,IREJ1)
6793 IF (IREJ1.GT.0) GOTO 9999
6794 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6795 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6796 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6797 IF (IREJ1.NE.0) GOTO 9999
6798 IF (IDR1.NE.0) IDR1 = 100*IDR1
6800 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6801 & AMCH1,AMCH1N,AMCH2,IREJ1)
6802 IF (IREJ1.GT.0) GOTO 9999
6803 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6804 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6805 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6806 IF (IREJ1.NE.0) GOTO 9999
6807 IF (IDR2.NE.0) IDR2 = 100*IDR2
6812 * store final configuration for energy-momentum cons. check
6814 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6815 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6816 IF (IREJ1.NE.0) GOTO 9999
6819 * put partons and chains into DTEVT1
6821 PCH1(I) = PP1(I)+PT1(I)
6822 PCH2(I) = PP2(I)+PT2(I)
6824 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6825 & PP1(3),PP1(4),0,0,0)
6826 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6827 & PT1(3),PT1(4),0,0,0)
6828 KCH = 100+IDCH(MOP1)*10+1
6829 CALL DT_EVTPUT(KCH,88888,-2,-1,
6830 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6831 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6832 & PP2(3),PP2(4),0,0,0)
6833 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6834 & PT2(3),PT2(4),0,0,0)
6836 CALL DT_EVTPUT(KCH,88888,-2,-1,
6837 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6842 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6843 * "cancel" sea-sea chains
6844 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6845 IF (IREJ1.NE.0) GOTO 9998
6846 **sr 16.5. flag for EVENTB
6855 *$ CREATE DT_CHKINE.FOR
6858 *===chkine=============================================================*
6860 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6861 & AMCH1,AMCH1N,AMCH2,IREJ)
6863 ************************************************************************
6864 * This subroutine replaces CORMOM. *
6865 * This version dated 05.01.95 is written by S. Roesler *
6866 ************************************************************************
6868 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6870 PARAMETER ( LINP = 10 ,
6873 PARAMETER (TINY10=1.0D-10)
6875 * flags for input different options
6876 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6877 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6878 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6880 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6881 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6882 & IREXCI(3),IRDIFF(2),IRINC
6884 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6885 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6890 SCALE = AMCH1N/MAX(AMCH1,TINY10)
6896 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6897 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6898 PP1(I) = SCALE*PP1(I)
6899 PT1(I) = SCALE*PT1(I)
6901 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6902 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6905 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6906 & (PP2(3)+PT2(3))**2 )
6907 AMCH22 = (ECH-PCH)*(ECH+PCH)
6908 IF (AMCH22.LT.0.0D0) THEN
6910 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6915 AMCH2 = SQRT(AMCH22)
6917 * put partons again on mass shell
6921 IF (JMSHL.EQ.1) THEN
6925 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6926 IF (IREJ1.NE.0) THEN
6927 IF (JMSHL.EQ.0) GOTO 9998
6939 IF (JMSHL.EQ.1) THEN
6943 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6944 IF (IREJ1.NE.0) THEN
6945 IF (JMSHL.EQ.0) GOTO 9998
6961 9997 IRCHKI(1) = IRCHKI(1)+1
6967 9998 IRCHKI(2) = IRCHKI(2)+1
6970 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
6975 *$ CREATE DT_CH2RES.FOR
6978 *===ch2res=============================================================*
6980 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
6981 & AM,AMN,IMODE,IREJ)
6983 ************************************************************************
6984 * Check chains for resonance production. *
6985 * This subroutine replaces COMCMA/COBCMA/COMCM2 *
6987 * IF1,2,3,4 input flavors (q,aq in any order) *
6989 * MODE = 1 check q-aq chain for meson-resonance *
6990 * = 2 check q-qq, aq-aqaq chain for baryon-resonance *
6991 * = 3 check qq-aqaq chain for lower mass cut *
6993 * IDR = 0 no resonances found *
6994 * = -1 pseudoscalar meson/octet baryon *
6995 * = 1 vector-meson/decuplet baryon *
6996 * IDXR BAMJET-index of corresponding resonance *
6997 * AMN mass of corresponding resonance *
6999 * IREJ rejection flag *
7000 * This version dated 06.01.95 is written by S. Roesler *
7001 ************************************************************************
7003 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7005 PARAMETER ( LINP = 10 ,
7009 * particle properties (BAMJET index convention)
7011 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7012 & IICH(210),IIBAR(210),K1(210),K2(210)
7013 * quark-content to particle index conversion (DTUNUC 1.x)
7014 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7015 & IA08(6,21),IA10(6,21)
7017 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7018 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7019 & IREXCI(3),IRDIFF(2),IRINC
7020 * flags for input different options
7021 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7022 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7023 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7025 DIMENSION IF(4),JF(4)
7028 C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7029 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7031 C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7035 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7036 WRITE(LOUT,1000) MODE
7037 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7038 & 1X,' program stopped')
7047 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7048 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7056 IF (IF(I).NE.0) THEN
7061 IF (NF.LE.MODE) THEN
7062 WRITE(LOUT,1001) MODE,IF
7063 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7064 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7070 * check for meson resonance
7074 IF (JF(2).GT.0) THEN
7078 IFPS = IMPS(IFAQ,IFQ)
7079 IFV = IMVE(IFAQ,IFQ)
7083 IF (AMX.LT.AMV) THEN
7084 IF (AMX.LT.AMPS) THEN
7085 IF (IMODE.GT.0) THEN
7086 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7088 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7092 * replace chain by pseudoscalar meson
7096 ELSEIF (AMX.LT.AMHI) THEN
7097 * replace chain by vector-meson
7104 * check for baryon resonance
7106 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7110 IF (AMX.LT.AM10) THEN
7111 IF (AMX.LT.AM8) THEN
7112 IF (IMODE.GT.0) THEN
7113 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7115 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7119 * replace chain by oktet baryon
7123 ELSEIF (AMX.LT.AMHI) THEN
7130 * check qq-aqaq for lower mass cut
7132 * empirical definition of AMHI to allow for (b-antib)-pair prod.
7134 IF (AMX.LT.AMHI) GOTO 9999
7138 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7139 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7141 IRRES(2) = IRRES(2)+1
7145 *$ CREATE DT_RJSEAC.FOR
7148 *===rjseac=============================================================*
7150 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7152 ************************************************************************
7153 * ReJection of SEA-sea Chains. *
7154 * MOP1/2 entries of projectile sea-partons in DTEVT1 *
7155 * MOT1/2 entries of projectile sea-partons in DTEVT1 *
7156 * This version dated 16.01.95 is written by S. Roesler *
7157 ************************************************************************
7159 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7161 PARAMETER ( LINP = 10 ,
7164 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7167 PARAMETER (NMXHKK=200000)
7168 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7169 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7170 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7171 * extended event history
7172 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7173 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7176 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7177 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7180 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7184 * projectile sea q-aq-pair
7185 * indices of sea-pair
7188 * index of mother-nucleon
7189 IDXNUC(1) = JMOHKK(1,MOP1)
7190 * status of valence quarks to be corrected
7193 * target sea q-aq-pair
7194 * indices of sea-pair
7197 * index of mother-nucleon
7198 IDXNUC(2) = JMOHKK(1,MOT1)
7199 * status of valence quarks to be corrected
7204 DO 2 I=NPOINT(2),NHKK
7205 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7206 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7207 * valence parton found
7208 * inrease 4-momentum by sea 4-momentum
7210 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7211 & PHKK(K,IDXSEA(N,2))
7213 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7214 & PHKK(2,I)**2-PHKK(3,I)**2))
7217 ISTHKK(IDXSEA(N,J)) = 100
7218 IDHKK(IDXSEA(N,J)) = 0
7219 JMOHKK(1,IDXSEA(N,J)) = 0
7220 JMOHKK(2,IDXSEA(N,J)) = 0
7221 JDAHKK(1,IDXSEA(N,J)) = 0
7222 JDAHKK(2,IDXSEA(N,J)) = 0
7224 PHKK(K,IDXSEA(N,J)) = ZERO
7225 VHKK(K,IDXSEA(N,J)) = ZERO
7226 WHKK(K,IDXSEA(N,J)) = ZERO
7228 PHKK(5,IDXSEA(N,J)) = ZERO
7233 IF (IDONE.NE.1) THEN
7234 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7235 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7236 & '-record!',/,1X,' sea-quark pairs ',
7237 & 2I5,4X,2I5,' could not be canceled!')
7249 *$ CREATE DT_VV2SCH.FOR
7252 *===vv2sch=============================================================*
7254 SUBROUTINE DT_VV2SCH
7256 ************************************************************************
7257 * Change Valence-Valence chain systems to Single CHain systems for *
7258 * hadron-nucleus collisions with meson or antibaryon projectile. *
7259 * (Reggeon contribution) *
7260 * The single chain system is approximately treated as one chain and a *
7262 * This version dated 18.01.95 is written by S. Roesler *
7263 ************************************************************************
7265 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7267 PARAMETER ( LINP = 10 ,
7270 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7275 PARAMETER (NMXHKK=200000)
7276 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7277 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7278 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7279 * extended event history
7280 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7281 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7283 * flags for input different options
7284 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7285 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7286 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7288 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7289 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7292 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7295 DATA LSTART /.TRUE./
7300 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7301 & 'valence chains treated')
7307 * get index of first chain
7308 DO 1 I=NPOINT(3),NHKK
7309 IF (IDHKK(I).EQ.88888) THEN
7316 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7317 & .AND.(NC.LT.NSTOP)) THEN
7318 * get valence-valence chains
7319 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7320 * get "mother"-hadron indices
7321 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7322 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7323 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7324 KTARG = IDT_ICIHAD(IDHKK(MO2))
7325 * Lab momentum of projectile hadron
7326 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7327 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7330 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7331 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7333 * single chain requested
7334 * get flavors of chain-end partons
7335 MO(1) = JMOHKK(1,NC)
7336 MO(2) = JMOHKK(2,NC)
7337 MO(3) = JMOHKK(1,NC+3)
7338 MO(4) = JMOHKK(2,NC+3)
7340 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7342 IF (ABS(IDHKK(MO(I))).GE.1000)
7343 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7345 * which one is the q-aq chain?
7346 * N1,N1+1 - DTEVT1-entries for q-aq system
7347 * N2,N2+1 - DTEVT1-entries for the other chain
7348 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7353 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7363 PT1(K) = PHKK(K,N1+1)
7365 PT2(K) = PHKK(K,N2+1)
7367 AMCH1 = PHKK(5,N1+2)
7368 AMCH2 = PHKK(5,N2+2)
7369 * get meson-identity corresponding to flavors of q-aq chain
7372 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7373 & ZERO,AMCH1N,1,IDUM)
7375 * change kinematics of chains
7376 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7377 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7378 & AMCH1,AMCH1N,AMCH2,IREJ1)
7379 IF (IREJ1.NE.0) GOTO 10
7380 * check second chain for resonance
7382 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7383 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7384 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7385 IF (IREJ1.NE.0) GOTO 10
7386 IF (IDR2.NE.0) IDR2 = 100*IDR2
7387 * add partons and chains to DTEVT1
7389 PCH1(K) = PP1(K)+PT1(K)
7390 PCH2(K) = PP2(K)+PT2(K)
7392 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7393 & PP1(3),PP1(4),0,0,0)
7394 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7395 & PT1(2),PT1(3),PT1(4),0,0,0)
7396 KCH = ISTHKK(N1+2)+100
7397 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7398 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7400 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7401 & PP2(3),PP2(4),0,0,0)
7402 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7403 & PT2(2),PT2(3),PT2(4),0,0,0)
7404 KCH = ISTHKK(N2+2)+100
7405 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7406 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7422 *$ CREATE DT_PHNSCH.FOR
7425 *=== phnsch ===========================================================*
7427 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7429 *----------------------------------------------------------------------*
7431 * Probability for Hadron Nucleon Single CHain interactions: *
7433 * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7436 * Last change on 04-jan-94 by Alfredo Ferrari *
7438 * modified by J.R.for use in DTUNUC 6.1.94 *
7440 * Input variables: *
7441 * Kp = hadron projectile index (Part numbering *
7443 * Ktarg = target nucleon index (1=proton, 8=neutron) *
7444 * Plab = projectile laboratory momentum (GeV/c) *
7445 * Output variable: *
7446 * Phnsch = probability per single chain (particle *
7447 * exchange) interactions *
7449 *----------------------------------------------------------------------*
7451 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7454 PARAMETER ( LUNOUT = 6 )
7455 PARAMETER ( LUNERR = 6 )
7456 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7457 PARAMETER ( ZERZER = 0.D+00 )
7458 PARAMETER ( ONEONE = 1.D+00 )
7459 PARAMETER ( TWOTWO = 2.D+00 )
7460 PARAMETER ( FIVFIV = 5.D+00 )
7461 PARAMETER ( HLFHLF = 0.5D+00 )
7463 PARAMETER ( NALLWP = 39 )
7464 PARAMETER ( IDMAXP = 210 )
7466 DIMENSION ICHRGE(39),AM(39)
7468 * particle properties (BAMJET index convention)
7470 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7471 & IICH(210),IIBAR(210),K1(210),K2(210)
7473 DIMENSION KPTOIP(210)
7474 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7475 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7476 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7477 & IQTCHR(-6:6),MQUARK(3,39)
7479 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7480 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7481 CPH SAVE SGTCOE, IHLP
7482 CPH SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7483 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7484 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7485 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7487 * Conversion from part to paprop numbering
7488 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7489 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7490 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7492 * 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7493 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7494 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7495 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7497 * 1st reaction: gamma p total
7498 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7499 * 2nd reaction: gamma d total
7500 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7501 * 3rd reaction: pi+ p total
7502 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7503 * 4th reaction: pi- p total
7504 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7505 * 5th reaction: pi+/- d total
7506 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7507 * 6th reaction: K+ p total
7508 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7509 * 7th reaction: K+ n total
7510 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7511 * 8th reaction: K+ d total
7512 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7513 * 9th reaction: K- p total
7514 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7515 * 10th reaction: K- n total
7516 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7517 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7519 * 11th reaction: K- d total
7520 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7521 * 12th reaction: p p total
7522 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7523 * 13th reaction: p n total
7524 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7525 * 14th reaction: p d total
7526 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
7527 * 15th reaction: pbar p total
7528 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
7529 * 16th reaction: pbar n total
7530 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
7531 * 17th reaction: pbar d total
7532 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
7533 * 18th reaction: Lamda p total
7534 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
7535 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7537 * 19th reaction: pi+ p elastic
7538 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
7539 * 20th reaction: pi- p elastic
7540 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
7541 * 21st reaction: K+ p elastic
7542 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
7543 * 22nd reaction: K- p elastic
7544 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
7545 * 23rd reaction: p p elastic
7546 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
7547 * 24th reaction: p d elastic
7548 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
7549 * 25th reaction: pbar p elastic
7550 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
7551 * 26th reaction: pbar p elastic bis
7552 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
7553 * 27th reaction: pbar n elastic
7554 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
7555 * 28th reaction: Lamda p elastic
7556 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
7557 * 29th reaction: K- p ela bis
7558 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
7559 * 30th reaction: pi- p cx
7560 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
7561 * 31st reaction: K- p cx
7562 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
7563 * 32nd reaction: K+ n cx
7564 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
7565 * 33rd reaction: pbar p cx
7566 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
7568 * +-------------------------------------------------------------------*
7569 ICHRGE(KTARG)=IICH(KTARG)
7570 AM (KTARG)=AAM (KTARG)
7571 * | Check for pi0 (d-dbar)
7572 IF ( KP .NE. 26 ) THEN
7578 * +-------------------------------------------------------------------*
7585 * +-------------------------------------------------------------------*
7586 * +-------------------------------------------------------------------*
7587 * | No such interactions for baryon-baryon
7588 IF ( IIBAR (KP) .GT. 0 ) THEN
7592 * +-------------------------------------------------------------------*
7593 * | No "annihilation" diagram possible for K+ p/n
7594 ELSE IF ( IP .EQ. 15 ) THEN
7598 * +-------------------------------------------------------------------*
7599 * | No "annihilation" diagram possible for K0 p/n
7600 ELSE IF ( IP .EQ. 24 ) THEN
7604 * +-------------------------------------------------------------------*
7605 * | No "annihilation" diagram possible for Omebar p/n
7606 ELSE IF ( IP .GE. 38 ) THEN
7611 * +-------------------------------------------------------------------*
7612 * +-------------------------------------------------------------------*
7613 * | If the momentum is larger than 50 GeV/c, compute the single
7614 * | chain probability at 50 GeV/c and extrapolate to the present
7615 * | momentum according to 1/sqrt(s)
7616 * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7617 * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7618 * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7619 * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7621 * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7622 IF ( PLAB .GT. 50.D+00 ) THEN
7625 AMTSQ = AM (KTARG)**2
7626 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7627 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7628 EPROJ = SQRT ( PLA**2 + AMPSQ )
7629 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7630 UMORAT = SQRT ( UMOSQ / UMO50 )
7632 * +-------------------------------------------------------------------*
7634 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7637 AMTSQ = AM (KTARG)**2
7638 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7639 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7640 EPROJ = SQRT ( PLA**2 + AMPSQ )
7641 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7642 UMORAT = SQRT ( UMOSQ / UMO50 )
7644 * +-------------------------------------------------------------------*
7651 * +-------------------------------------------------------------------*
7653 * +-------------------------------------------------------------------*
7655 IF ( IHLP (IP) .EQ. 2 ) THEN
7661 * | Compute the pi+ p total cross section:
7662 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7664 ACOF = SGTCOE (1,19)
7665 BCOF = SGTCOE (2,19)
7666 ENNE = SGTCOE (3,19)
7667 CCOF = SGTCOE (4,19)
7668 DCOF = SGTCOE (5,19)
7669 * | Compute the pi+ p elastic cross section:
7670 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7672 * | Compute the pi+ p inelastic cross section:
7673 SPPPIN = SPPPTT - SPPPEL
7679 * | Compute the pi- p total cross section:
7680 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7682 ACOF = SGTCOE (1,20)
7683 BCOF = SGTCOE (2,20)
7684 ENNE = SGTCOE (3,20)
7685 CCOF = SGTCOE (4,20)
7686 DCOF = SGTCOE (5,20)
7687 * | Compute the pi- p elastic cross section:
7688 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7690 * | Compute the pi- p inelastic cross section:
7691 SPMPIN = SPMPTT - SPMPEL
7692 SIGDIA = SPMPIN - SPPPIN
7693 * | +----------------------------------------------------------------*
7694 * | | Charged pions: besides isospin consideration it is supposed
7695 * | | that (pi+ n)el is almost equal to (pi- p)el
7696 * | | and (pi+ p)el " " " " (pi- n)el
7697 * | | and all are almost equal among each others
7698 * | | (reasonable above 5 GeV/c)
7699 IF ( ICHRGE (IP) .NE. 0 ) THEN
7701 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7702 ACOF = SGTCOE (1,JREAC)
7703 BCOF = SGTCOE (2,JREAC)
7704 ENNE = SGTCOE (3,JREAC)
7705 CCOF = SGTCOE (4,JREAC)
7706 DCOF = SGTCOE (5,JREAC)
7707 * | | Compute the total cross section:
7708 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7710 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7711 ACOF = SGTCOE (1,JREAC)
7712 BCOF = SGTCOE (2,JREAC)
7713 ENNE = SGTCOE (3,JREAC)
7714 CCOF = SGTCOE (4,JREAC)
7715 DCOF = SGTCOE (5,JREAC)
7716 * | | Compute the elastic cross section:
7717 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7719 * | | Compute the inelastic cross section:
7720 SHNCIN = SHNCTT - SHNCEL
7721 * | | Number of diagrams:
7722 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7723 * | | Now compute the chain end (anti)quark-(anti)diquark
7724 IQFSC1 = 1 + IP - 13
7727 IQBSC2 = 1 + IP - 13
7729 * | +----------------------------------------------------------------*
7730 * | | pi0: besides isospin consideration it is supposed that the
7731 * | | elastic cross section is not very different from
7732 * | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
7735 K2HLP = ( KP - 23 ) / 3
7736 * | | Number of diagrams:
7737 * | | For u ubar (k2hlp=0):
7738 * NDIAGR = 2 - KHELP
7739 * | | For d dbar (k2hlp=1):
7740 * NDIAGR = 2 + KHELP - K2HLP
7741 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7742 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7743 * | | Now compute the chain end (anti)quark-(anti)diquark
7750 * | +----------------------------------------------------------------*
7752 * +-------------------------------------------------------------------*
7754 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7760 * | Compute the K+ p total cross section:
7761 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7763 ACOF = SGTCOE (1,21)
7764 BCOF = SGTCOE (2,21)
7765 ENNE = SGTCOE (3,21)
7766 CCOF = SGTCOE (4,21)
7767 DCOF = SGTCOE (5,21)
7768 * | Compute the K+ p elastic cross section:
7769 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7771 * | Compute the K+ p inelastic cross section:
7772 SKPPIN = SKPPTT - SKPPEL
7778 * | Compute the K- p total cross section:
7779 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7781 ACOF = SGTCOE (1,22)
7782 BCOF = SGTCOE (2,22)
7783 ENNE = SGTCOE (3,22)
7784 CCOF = SGTCOE (4,22)
7785 DCOF = SGTCOE (5,22)
7786 * | Compute the K- p elastic cross section:
7787 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7789 * | Compute the K- p inelastic cross section:
7790 SKMPIN = SKMPTT - SKMPEL
7791 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7792 * | +----------------------------------------------------------------*
7793 * | | Charged Kaons: actually only K-
7794 IF ( ICHRGE (IP) .NE. 0 ) THEN
7796 * | | +-------------------------------------------------------------*
7797 * | | | Proton target:
7798 IF ( KHELP .EQ. 0 ) THEN
7800 * | | | Number of diagrams:
7803 * | | +-------------------------------------------------------------*
7804 * | | | Neutron target: besides isospin consideration it is supposed
7805 * | | | that (K- n)el is almost equal to (K- p)el
7806 * | | | (reasonable above 5 GeV/c)
7808 ACOF = SGTCOE (1,10)
7809 BCOF = SGTCOE (2,10)
7810 ENNE = SGTCOE (3,10)
7811 CCOF = SGTCOE (4,10)
7812 DCOF = SGTCOE (5,10)
7813 * | | | Compute the total cross section:
7814 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7816 * | | | Compute the elastic cross section:
7818 * | | | Compute the inelastic cross section:
7819 SHNCIN = SHNCTT - SHNCEL
7820 * | | | Number of diagrams:
7824 * | | +-------------------------------------------------------------*
7825 * | | Now compute the chain end (anti)quark-(anti)diquark
7831 * | +----------------------------------------------------------------*
7832 * | | K0's: (actually only K0bar)
7835 * | | +-------------------------------------------------------------*
7836 * | | | Proton target: (K0bar p)in supposed to be given by
7837 * | | | (K- p)in - Sig_diagr
7838 IF ( KHELP .EQ. 0 ) THEN
7839 SHNCIN = SKMPIN - SIGDIA
7840 * | | | Number of diagrams:
7843 * | | +-------------------------------------------------------------*
7844 * | | | Neutron target: (K0bar n)in supposed to be given by
7845 * | | | (K- n)in + Sig_diagr
7846 * | | | besides isospin consideration it is supposed
7847 * | | | that (K- n)el is almost equal to (K- p)el
7848 * | | | (reasonable above 5 GeV/c)
7850 ACOF = SGTCOE (1,10)
7851 BCOF = SGTCOE (2,10)
7852 ENNE = SGTCOE (3,10)
7853 CCOF = SGTCOE (4,10)
7854 DCOF = SGTCOE (5,10)
7855 * | | | Compute the total cross section:
7856 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7858 * | | | Compute the elastic cross section:
7860 * | | | Compute the inelastic cross section:
7861 SHNCIN = SHNCTT - SHNCEL + SIGDIA
7862 * | | | Number of diagrams:
7866 * | | +-------------------------------------------------------------*
7867 * | | Now compute the chain end (anti)quark-(anti)diquark
7874 * | +----------------------------------------------------------------*
7876 * +-------------------------------------------------------------------*
7878 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7879 * | For momenta between 3 and 5 GeV/c the use of tabulated data
7880 * | should be implemented!
7881 ACOF = SGTCOE (1,15)
7882 BCOF = SGTCOE (2,15)
7883 ENNE = SGTCOE (3,15)
7884 CCOF = SGTCOE (4,15)
7885 DCOF = SGTCOE (5,15)
7886 * | Compute the pbar p total cross section:
7887 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7889 IF ( PLA .LT. FIVFIV ) THEN
7894 ACOF = SGTCOE (1,JREAC)
7895 BCOF = SGTCOE (2,JREAC)
7896 ENNE = SGTCOE (3,JREAC)
7897 CCOF = SGTCOE (4,JREAC)
7898 DCOF = SGTCOE (5,JREAC)
7899 * | Compute the pbar p elastic cross section:
7900 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7902 * | Compute the pbar p inelastic cross section:
7903 SAPPIN = SAPPTT - SAPPEL
7904 ACOF = SGTCOE (1,12)
7905 BCOF = SGTCOE (2,12)
7906 ENNE = SGTCOE (3,12)
7907 CCOF = SGTCOE (4,12)
7908 DCOF = SGTCOE (5,12)
7909 * | Compute the p p total cross section:
7910 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7912 ACOF = SGTCOE (1,23)
7913 BCOF = SGTCOE (2,23)
7914 ENNE = SGTCOE (3,23)
7915 CCOF = SGTCOE (4,23)
7916 DCOF = SGTCOE (5,23)
7917 * | Compute the p p elastic cross section:
7918 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7920 * | Compute the K- p inelastic cross section:
7921 SPPINE = SPPTOT - SPPELA
7922 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7924 * | +----------------------------------------------------------------*
7926 IF ( ICHRGE (IP) .NE. 0 ) THEN
7928 * | | +-------------------------------------------------------------*
7929 * | | | Proton target:
7930 IF ( KHELP .EQ. 0 ) THEN
7931 * | | | Number of diagrams:
7935 * | | +-------------------------------------------------------------*
7936 * | | | Neutron target: it is supposed that (ap n)el is almost equal
7937 * | | | to (ap p)el (reasonable above 5 GeV/c)
7939 ACOF = SGTCOE (1,16)
7940 BCOF = SGTCOE (2,16)
7941 ENNE = SGTCOE (3,16)
7942 CCOF = SGTCOE (4,16)
7943 DCOF = SGTCOE (5,16)
7944 * | | | Compute the total cross section:
7945 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7947 * | | | Compute the elastic cross section:
7949 * | | | Compute the inelastic cross section:
7950 SHNCIN = SHNCTT - SHNCEL
7954 * | | +-------------------------------------------------------------*
7955 * | | Now compute the chain end (anti)quark-(anti)diquark
7956 * | | there are different possibilities, make a random choiche:
7958 RNCHEN = DT_RNDM(PUUBAR)
7959 IF ( RNCHEN .LT. PUUBAR ) THEN
7964 IQBSC1 = -IQFSC1 + KHELP
7967 * | +----------------------------------------------------------------*
7971 * | | +-------------------------------------------------------------*
7972 * | | | Proton target: (nbar p)in supposed to be given by
7973 * | | | (pbar p)in - Sig_diagr
7974 IF ( KHELP .EQ. 0 ) THEN
7975 SHNCIN = SAPPIN - SIGDIA
7978 * | | +-------------------------------------------------------------*
7979 * | | | Neutron target: (nbar n)el is supposed to be equal to
7980 * | | | (pbar p)el (reasonable above 5 GeV/c)
7982 * | | | Compute the total cross section:
7984 * | | | Compute the elastic cross section:
7986 * | | | Compute the inelastic cross section:
7987 SHNCIN = SHNCTT - SHNCEL
7991 * | | +-------------------------------------------------------------*
7992 * | | Now compute the chain end (anti)quark-(anti)diquark
7993 * | | there are different possibilities, make a random choiche:
7995 RNCHEN = DT_RNDM(RNCHEN)
7996 IF ( RNCHEN .LT. PDDBAR ) THEN
8001 IQBSC1 = -IQFSC1 + KHELP - 1
8005 * | +----------------------------------------------------------------*
8007 * +-------------------------------------------------------------------*
8008 * | Others: not yet implemented
8017 * +-------------------------------------------------------------------*
8018 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8019 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8021 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8025 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8027 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8028 & + IQSCHR (MQUARK(3,IP))
8029 * +-------------------------------------------------------------------*
8030 * | Consistency check:
8031 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8032 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8033 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8034 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8035 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8036 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8037 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8040 * +-------------------------------------------------------------------*
8041 * +-------------------------------------------------------------------*
8042 * | Consistency check:
8043 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8044 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8046 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8047 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8049 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8050 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8053 * +-------------------------------------------------------------------*
8054 * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8055 IF ( UMORAT .GT. ONEPLS )
8056 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8057 & - ONEONE ) * UMORAT + ONEONE )
8060 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8066 *=== End of function Phnsch ===========================================*
8070 *$ CREATE DT_RESPT.FOR
8073 *===respt==============================================================*
8077 ************************************************************************
8078 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8079 * This version dated 18.01.95 is written by S. Roesler *
8080 ************************************************************************
8082 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8084 PARAMETER ( LINP = 10 ,
8087 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8090 PARAMETER (NMXHKK=200000)
8091 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8092 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8093 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8094 * extended event history
8095 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8096 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8099 * get index of first chain
8100 DO 1 I=NPOINT(3),NHKK
8101 IF (IDHKK(I).EQ.88888) THEN
8108 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8109 C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8110 * skip VV-,SS- systems
8111 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8112 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8113 * check if both "chains" are resonances
8114 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8115 CALL DT_SAPTRE(NC,NC+3)
8129 *$ CREATE DT_EVTRES.FOR
8132 *===evtres=============================================================*
8134 SUBROUTINE DT_EVTRES(IREJ)
8136 ************************************************************************
8137 * This version dated 14.12.94 is written by S. Roesler *
8138 ************************************************************************
8140 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8142 PARAMETER ( LINP = 10 ,
8145 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8148 PARAMETER (NMXHKK=200000)
8149 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8150 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8151 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8152 * extended event history
8153 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8154 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8156 * flags for input different options
8157 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8158 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8159 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8160 * particle properties (BAMJET index convention)
8162 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8163 & IICH(210),IIBAR(210),K1(210),K2(210)
8165 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8169 DO 1 I=NPOINT(3),NHKK
8170 IF (ABS(IDRES(I)).GE.100) THEN
8172 DO 2 J=NPOINT(3),NHKK
8173 IF (IDHKK(J).EQ.88888) THEN
8174 IF (PHKK(5,J).GT.AMMX) THEN
8180 IF (IDRES(IMMX).NE.0) THEN
8181 IF (IOULEV(3).GT.0) THEN
8182 WRITE(LOUT,'(1X,A)')
8183 & 'EVTRES: no chain for correc. found'
8192 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8196 IMO21 = JMOHKK(1,IMMX)
8197 IMO22 = JMOHKK(2,IMMX)
8198 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8199 IMO21 = JMOHKK(2,IMMX)
8200 IMO22 = JMOHKK(1,IMMX)
8203 AMCH1N = AAM(IDXRES(I))
8205 IFPR1 = IDHKK(IMO11)
8206 IFPR2 = IDHKK(IMO21)
8207 IFTA1 = IDHKK(IMO12)
8208 IFTA2 = IDHKK(IMO22)
8210 PP1(J) = PHKK(J,IMO11)
8211 PP2(J) = PHKK(J,IMO21)
8212 PT1(J) = PHKK(J,IMO12)
8213 PT2(J) = PHKK(J,IMO22)
8215 * store initial configuration for energy-momentum cons. check
8216 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8217 * correct kinematics of second chain
8218 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8219 & AMCH1,AMCH1N,AMCH2,IREJ1)
8220 IF (IREJ1.NE.0) GOTO 9999
8221 * check now this chain for resonance mass
8222 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8224 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8225 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8227 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8229 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8230 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8231 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8232 & AMCH2,AMCH2N,IDCH2,IREJ1)
8233 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8235 & WRITE(LOUT,*) ' correction for resonance not poss.'
8241 * store final configuration for energy-momentum cons. check
8243 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8244 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8245 IF (IREJ1.NE.0) GOTO 9999
8248 PHKK(J,IMO11) = PP1(J)
8249 PHKK(J,IMO21) = PP2(J)
8250 PHKK(J,IMO12) = PT1(J)
8251 PHKK(J,IMO22) = PT2(J)
8253 * correct entries of chains
8255 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8256 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8258 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8259 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8261 * ?? the following should now be obsolete
8263 C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8264 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8266 WRITE(LOUT,'(1X,A,4G10.3)')
8267 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8271 PHKK(5,I) = SQRT(AM1)
8272 PHKK(5,IMMX) = SQRT(AM2)
8273 IDRES(I) = IDRES(I)/100
8274 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8275 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8276 WRITE(LOUT,'(1X,A,4G10.3)')
8277 & 'EVTRES: inconsistent chain-masses',
8278 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8291 *$ CREATE DT_GETSPT.FOR
8294 *===getspt=============================================================*
8296 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8297 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8298 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8300 ************************************************************************
8301 * This version dated 12.12.94 is written by S. Roesler *
8302 ************************************************************************
8304 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8306 PARAMETER ( LINP = 10 ,
8309 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8311 * various options for treatment of partons (DTUNUC 1.x)
8312 * (chain recombination, Cronin,..)
8313 LOGICAL LCO2CR,LINTPT
8314 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8316 * flags for input different options
8317 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8318 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8319 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8320 * flags for diffractive interactions (DTUNUC 1.x)
8321 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8323 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8324 & PT2(4),PT2I(4),P1(4),P2(4),
8325 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8326 & PTOTI(4),PTOTF(4),DIFF(4)
8332 C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8333 C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8339 IF (IDIFF.NE.0) THEN
8345 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8351 * get initial chain masses
8352 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8353 & +(PP1(3)+PT1(3))**2)
8355 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8356 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8357 & +(PP2(3)+PT2(3))**2)
8359 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8360 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8362 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8372 C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8376 C IF (AM1.LT.0.6) THEN
8378 C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8381 C IF (AM2.LT.0.6) THEN
8383 C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8388 * check chain masses for very low mass chains
8389 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8390 C & AM1,DUM,-IDCH1,IREJ1)
8391 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8392 C & AM2,DUM,-IDCH2,IREJ2)
8393 C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8402 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8403 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8404 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8405 C IF (MOD(IC,19).EQ.0) JMSHL = 0
8406 IF (MOD(IC,20).EQ.0) GOTO 7
8407 C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8412 * get transverse momentum
8414 ES = -2.0D0/(B33P**2)
8415 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8416 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8418 ES = -2.0D0/(B33T**2)
8419 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8420 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8426 CALL DT_DSFECF(SFE1,CFE1)
8427 CALL DT_DSFECF(SFE2,CFE2)
8429 PP1(1) = PP1I(1)+HPSP*CFE1
8430 PP1(2) = PP1I(2)+HPSP*SFE1
8431 PP2(1) = PP2I(1)-HPSP*CFE1
8432 PP2(2) = PP2I(2)-HPSP*SFE1
8433 PT1(1) = PT1I(1)+HPST*CFE2
8434 PT1(2) = PT1I(2)+HPST*SFE2
8435 PT2(1) = PT2I(1)-HPST*CFE2
8436 PT2(2) = PT2I(2)-HPST*SFE2
8438 PP1(1) = PP1I(1)+HPSP*CFE1
8439 PP1(2) = PP1I(2)+HPSP*SFE1
8440 PT1(1) = PT1I(1)-HPSP*CFE1
8441 PT1(2) = PT1I(2)-HPSP*SFE1
8442 PP2(1) = PP2I(1)+HPST*CFE2
8443 PP2(2) = PP2I(2)+HPST*SFE2
8444 PT2(1) = PT2I(1)-HPST*CFE2
8445 PT2(2) = PT2I(2)-HPST*SFE2
8448 * put partons on mass shell
8451 IF (JMSHL.EQ.1) THEN
8452 XMP1 = PYMASS(IFPR1)
8453 XMT1 = PYMASS(IFTA1)
8455 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8456 IF (IREJ1.NE.0) GOTO 2
8458 PTOTF(I) = P1(I)+P2(I)
8464 IF (JMSHL.EQ.1) THEN
8465 XMP2 = PYMASS(IFPR2)
8466 XMT2 = PYMASS(IFTA2)
8468 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8469 IF (IREJ1.NE.0) GOTO 2
8471 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8478 DIFF(I) = PTOTI(I)-PTOTF(I)
8480 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8481 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8482 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8485 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8486 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8487 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8488 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8489 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8490 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8491 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8492 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8493 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8494 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8496 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8497 & 'GETSPT: inconsistent masses',
8498 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8499 * sr 22.11.00: commented. It should only have inconsistent masses for
8500 * ultrahigh energies due to rounding problems
8505 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8506 & +(PP1(3)+PT1(3))**2)
8508 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
8509 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8510 & +(PP2(3)+PT2(3))**2)
8512 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
8513 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8515 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8522 * check chain masses for very low mass chains
8523 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8524 & AM1N,DUM,-IDCH1,IREJ1)
8525 IF (IREJ1.NE.0) GOTO 2
8526 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8527 & AM2N,DUM,-IDCH2,IREJ2)
8528 IF (IREJ2.NE.0) GOTO 2
8531 IF (AM1N.GT.ZERO) THEN
8549 *$ CREATE DT_SAPTRE.FOR
8552 *===saptre=============================================================*
8554 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8556 ************************************************************************
8557 * p-t sampling for two-resonance systems. ("BAMJET-like" method) *
8558 * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
8559 * Adopted from the original SAPTRE written by J. Ranft. *
8560 * This version dated 18.01.95 is written by S. Roesler *
8561 ************************************************************************
8563 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8565 PARAMETER ( LINP = 10 ,
8568 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8571 PARAMETER (NMXHKK=200000)
8572 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8573 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8574 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8575 * extended event history
8576 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8577 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8579 * flags for input different options
8580 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8581 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8582 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8584 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8588 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8589 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8590 ESMAX = MIN(ESMAX1,ESMAX2)
8591 IF (ESMAX.LE.0.05D0) RETURN
8595 PA1(K) = PHKK(K,IDX1)
8596 PA2(K) = PHKK(K,IDX2)
8600 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8601 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8605 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8606 BEXP = HMA*(1.0D0-EXEB)/B3
8607 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8608 WA = AXEXP/(BEXP+AXEXP)
8611 * ES is the transverse kinetic energy
8615 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8618 ES = ABS(-LOG(X+TINY7)/B3)
8620 IF (ES.GT.ESMAX) GOTO 10
8622 * transverse momentum
8623 HPS = SQRT((ES-HMA)*(ES+HMA))
8625 CALL DT_DSFECF(SFE,CFE)
8628 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8629 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8630 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8632 C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8633 C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8639 * put resonances on mass-shell again
8642 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8643 IF (IREJ1.NE.0) RETURN
8646 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8647 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8648 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8649 IF (IREJ1.NE.0) RETURN
8653 PHKK(K,IDX1) = P1(K)
8654 PHKK(K,IDX2) = P2(K)
8660 *$ CREATE DT_CRONIN.FOR
8663 *===cronin=============================================================*
8665 SUBROUTINE DT_CRONIN(INCL)
8667 ************************************************************************
8668 * Cronin-Effect. Multiple scattering of partons at chain ends. *
8669 * INCL = 1 multiple sc. in projectile *
8670 * = 2 multiple sc. in target *
8671 * This version dated 05.01.96 is written by S. Roesler. *
8672 ************************************************************************
8674 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8676 PARAMETER ( LINP = 10 ,
8679 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8682 PARAMETER (NMXHKK=200000)
8683 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8684 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8685 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8686 * extended event history
8687 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8688 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8691 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8692 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8693 & IREXCI(3),IRDIFF(2),IRINC
8694 * Glauber formalism: collision properties
8695 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8696 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8698 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8704 DO 2 I=NPOINT(2),NHKK
8705 IF (ISTHKK(I).LT.0) THEN
8706 * get z-position of the chain
8707 R(1) = VHKK(1,I)*1.0D12
8708 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8709 R(2) = VHKK(2,I)*1.0D12
8711 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8712 & IDXNU = JMOHKK(1,I-1)
8713 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8714 & IDXNU = JMOHKK(1,I+1)
8715 R(3) = VHKK(3,IDXNU)*1.0D12
8716 * position of target parton the chain is connected to
8720 * multiple scattering of parton with DTEVT1-index I
8721 CALL DT_CROMSC(PIN,R,POUT,INCL)
8723 C IF (NEVHKK.EQ.5) THEN
8724 C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8725 C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8726 C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8727 C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8728 C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8729 C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
8730 C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
8733 * increase accumulator by energy-momentum difference
8735 DEV(K) = DEV(K)+POUT(K)-PIN(K)
8738 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8739 & PHKK(2,I)**2-PHKK(3,I)**2))
8743 * dump accumulator to momenta of valence partons
8746 DO 5 I=NPOINT(2),NHKK
8747 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8749 ETOT = ETOT+PHKK(4,I)
8752 C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8753 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
8755 DO 6 I=NPOINT(2),NHKK
8756 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8759 C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8760 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8762 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8763 & PHKK(2,I)**2-PHKK(3,I)**2))
8770 *$ CREATE DT_CROMSC.FOR
8773 *===cromsc=============================================================*
8775 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8777 ************************************************************************
8778 * Cronin-Effect. Multiple scattering of one parton passing through *
8780 * PIN(4) input 4-momentum of parton *
8781 * POUT(4) 4-momentum of parton after mult. scatt. *
8782 * R(3) spatial position of parton in target nucleus *
8783 * INCL = 1 multiple sc. in projectile *
8784 * = 2 multiple sc. in target *
8785 * This is a revised version of the original version written by J. Ranft*
8786 * This version dated 17.01.95 is written by S. Roesler. *
8787 ************************************************************************
8789 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8791 PARAMETER ( LINP = 10 ,
8794 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8799 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8800 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8801 & IREXCI(3),IRDIFF(2),IRINC
8802 * Glauber formalism: collision properties
8803 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8804 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8805 * various options for treatment of partons (DTUNUC 1.x)
8806 * (chain recombination, Cronin,..)
8807 LOGICAL LCO2CR,LINTPT
8808 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8811 DIMENSION PIN(4),POUT(4),R(3)
8813 DATA LSTART /.TRUE./
8815 IRCRON(1) = IRCRON(1)+1
8818 WRITE(LOUT,1000) CRONCO
8819 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
8820 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8826 IF (INCL.EQ.2) RNCL = RTARG
8828 * Lorentz-transformation into Lab.
8830 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8832 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8833 IF (PTOT.LE.8.0D0) GOTO 9997
8835 * direction cosines of parton before mult. scattering
8840 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8841 IF (RTESQ.GE.-TINY3) GOTO 9999
8843 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8844 * in the direction of particle motion
8846 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8848 IF (TMP.LT.ZERO) GOTO 9998
8851 * multiple scattering angle
8852 THETO = CRONCO*SQRT(DIST)/PTOT
8853 IF (THETO.GT.0.1D0) THETO=0.1D0
8856 * Gaussian sampling of spatial angle
8857 CALL DT_RANNOR(R1,R2)
8858 THETA = ABS(R1*THETO)
8859 IF (THETA.GT.0.3D0) GOTO 9997
8860 CALL DT_DSFECF(SFE,CFE)
8864 * new direction cosines
8865 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8866 & COSXN,COSYN,COSZN)
8868 POUT(1) = COSXN*PTOT
8869 POUT(2) = COSYN*PTOT
8871 * Lorentz-transformation into nucl.-nucl. cms
8873 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8875 C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8876 C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8877 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8880 IF (MOD(NCBACK,200).EQ.0) THEN
8881 WRITE(LOUT,1001) THETO,PIN,POUT
8882 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8883 & E12.4,/,1X,' PIN :',4E12.4,/,
8884 & 1X,' POUT:',4E12.4)
8892 9997 IRCRON(2) = IRCRON(2)+1
8894 9998 IRCRON(3) = IRCRON(3)+1
8903 *$ CREATE DT_COM2CR.FOR
8906 *===com2sr=============================================================*
8908 SUBROUTINE DT_COM2CR
8910 ************************************************************************
8911 * COMbine q-aq chains to Color Ropes (qq-aqaq). *
8912 * CUTOF parameter determining minimum number of not *
8913 * combined q-aq chains *
8914 * This subroutine replaces KKEVCC etc. *
8915 * This version dated 11.01.95 is written by S. Roesler. *
8916 ************************************************************************
8918 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8920 PARAMETER ( LINP = 10 ,
8925 PARAMETER (NMXHKK=200000)
8926 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8927 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8928 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8929 * extended event history
8930 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8931 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8934 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8935 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8937 * various options for treatment of partons (DTUNUC 1.x)
8938 * (chain recombination, Cronin,..)
8939 LOGICAL LCO2CR,LINTPT
8940 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8943 DIMENSION IDXQA(248),IDXAQ(248)
8945 ICCHAI(1,9) = ICCHAI(1,9)+1
8948 * scan DTEVT1 for q-aq, aq-q chains
8949 DO 10 I=NPOINT(3),NHKK
8950 * skip "chains" which are resonances
8951 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8954 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8955 * q-aq, aq-q chain found, keep index
8956 IF (IDHKK(MO1).GT.0) THEN
8967 * minimum number of q-aq chains requested for the same projectile/
8969 NCHMIN = IDT_NPOISS(CUTOF)
8971 * combine q-aq chains of the same projectile
8972 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
8973 * combine q-aq chains of the same target
8974 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
8975 * combine aq-q chains of the same projectile
8976 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
8977 * combine aq-q chains of the same target
8978 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
8983 *$ CREATE DT_SCN4CR.FOR
8986 *===scn4cr=============================================================*
8988 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
8990 ************************************************************************
8991 * SCan q-aq chains for Color Ropes. *
8992 * This version dated 11.01.95 is written by S. Roesler. *
8993 ************************************************************************
8995 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8997 PARAMETER ( LINP = 10 ,
9002 PARAMETER (NMXHKK=200000)
9003 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9004 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9005 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9006 * extended event history
9007 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9008 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9011 DIMENSION IDXCH(248),IDXJN(248)
9014 IF (IDXCH(I).GT.0) THEN
9016 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9020 IF (IDXCH(J).GT.0) THEN
9021 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9022 IF (IDXMO.EQ.IDXMO1) THEN
9029 IF (NJOIN.GE.NCHMIN+2) THEN
9030 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9032 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9033 IF (IREJ1.NE.0) GOTO 3
9035 IDXCH(IDXJN(J+1)) = 0
9044 *$ CREATE DT_JOIN.FOR
9047 *===join===============================================================*
9049 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9051 ************************************************************************
9052 * This subroutine joins two q-aq chains to one qq-aqaq chain. *
9053 * IDX1, IDX2 DTEVT1 indices of chains to be joined *
9054 * This version dated 11.01.95 is written by S. Roesler. *
9055 ************************************************************************
9057 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9059 PARAMETER ( LINP = 10 ,
9064 PARAMETER (NMXHKK=200000)
9065 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9066 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9067 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9068 * extended event history
9069 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9070 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9072 * flags for input different options
9073 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9074 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9075 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9077 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9078 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9081 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9089 MO(I,J) = JMOHKK(J,IDX(I))
9090 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9095 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9096 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9097 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9098 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9099 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9101 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9102 & 2I5,' chain ',I4,':',2I5)
9107 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9108 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9110 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9111 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9112 IST1 = ISTHKK(MO(1,1))
9113 IST2 = ISTHKK(MO(1,2))
9115 * put partons again on mass shell
9118 IF (IMSHL.EQ.1) THEN
9122 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9123 IF (IREJ1.NE.0) GOTO 9999
9129 * store new partons in DTEVT1
9130 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9132 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9135 PCH(K) = PP(K)+PT(K)
9138 * check new chain for lower mass limit
9139 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9140 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9141 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9142 & AMCH,AMCHN,3,IREJ1)
9143 IF (IREJ1.NE.0) THEN
9149 ICCHAI(2,9) = ICCHAI(2,9)+1
9150 * store new chain in DTEVT1
9152 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9153 IDHKK(IDX(1)) = 22222
9154 IDHKK(IDX(2)) = 22222
9155 * special treatment for space-time coordinates
9157 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9158 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9167 *$ CREATE DT_XSGLAU.FOR
9170 *===xsglau=============================================================*
9172 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9174 ************************************************************************
9175 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9176 * Glauber's approach. *
9177 * NA / NB mass numbers of proj./target nuclei *
9178 * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9179 * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9180 * IE,IQ indices of energy and virtuality (the latter for gamma *
9181 * projectiles only) *
9182 * NIDX index of projectile/target nucleus *
9183 * This version dated 17.3.98 is written by S. Roesler *
9184 ************************************************************************
9186 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9188 PARAMETER ( LINP = 10 ,
9192 COMPLEX*16 CZERO,CONE,CTWO
9194 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9195 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9196 PARAMETER (TWOPI = 6.283185307179586454D+00,
9198 & GEV2MB = 0.38938D0,
9199 & GEV2FM = 0.1972D0,
9200 & ALPHEM = ONE/137.0D0,
9204 * approx. nucleon radius
9207 * particle properties (BAMJET index convention)
9209 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9210 & IICH(210),IIBAR(210),K1(210),K2(210)
9211 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9212 PARAMETER ( MAXNCL = 260,
9214 & MAXSQU = 20*MAXVQU,
9215 & MAXINT = MAXVQU+MAXSQU)
9216 * Glauber formalism: parameters
9217 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9218 & BMAX(NCOMPX),BSTEP(NCOMPX),
9219 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9221 * Glauber formalism: cross sections
9222 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9223 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9224 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9225 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9226 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9227 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9228 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9229 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9230 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9231 & BSLOPE,NEBINI,NQBINI
9232 * Glauber formalism: flags and parameters for statistics
9235 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9236 * nucleon-nucleon event-generator
9239 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9240 * VDM parameter for photon-nucleus interactions
9241 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9242 * parameters for hA-diffraction
9243 COMMON /DTDIHA/ DIBETA,DIALPH
9245 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9246 & OMPP11,OMPP12,OMPP21,OMPP22,
9247 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9250 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9251 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9254 PARAMETER (NPOINT=16)
9255 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9257 LOGICAL LFIRST,LOPEN
9258 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9261 * for quasi-elastic neutrino scattering set projectile to proton
9262 * it should not have an effect since the whole Glauber-formalism is
9263 * not needed for these interactions..
9264 IF (MCGENE.EQ.4) THEN
9270 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9273 CFILE = CGLB//'.glb'
9274 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9275 ELSEIF (I.GT.1) THEN
9276 CFILE = CGLB(1:I-1)//'.glb'
9277 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9284 CZERO = DCMPLX(ZERO,ZERO)
9285 CONE = DCMPLX(ONE,ZERO)
9286 CTWO = DCMPLX(TWO,ZERO)
9290 * re-define kinematics
9294 * g(Q2=0)-A, h-A, A-A scattering
9295 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9298 * g(Q2>0)-A scattering
9299 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9301 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9302 Q2 = (S-AMP2)*X/(ONE-X)
9303 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9304 S = Q2*(ONE-X)/X+AMP2
9306 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9311 XNU = (S+Q2-AMP2)/(TWO*AMP)
9313 * parameters determining statistics in evaluating Glauber-xsection
9316 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9318 * set up interaction geometry (common /DTGLAM/)
9319 * projectile/target radii
9320 RPRNCL = DT_RNCLUS(NA)
9321 RTANCL = DT_RNCLUS(NB)
9322 IF (IJPROJ.EQ.7) THEN
9324 RBSH(NTARG) = RTANCL
9325 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9327 IF (NIDX.LE.-1) THEN
9329 RBSH(NTARG) = RTANCL
9330 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9332 RASH(NTARG) = RPRNCL
9334 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9337 * maximum impact-parameter
9338 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9340 * slope, rho ( Re(f(0))/Im(f(0)) )
9341 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9342 IF (MCGENE.EQ.2) THEN
9344 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9347 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9349 IF (ECMNN(IE).LE.3.0D0) THEN
9351 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9352 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9353 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9356 ELSEIF (IJPROJ.EQ.7) THEN
9359 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9363 * projectile-nucleon xsection (in fm)
9364 IF (IJPROJ.EQ.7) THEN
9365 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9367 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9368 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9369 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9371 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9372 SIGSH = SIGSH/10.0D0
9375 * parameters for projectile diffraction (hA scattering only)
9376 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9377 & .AND.(DIBETA.GE.ZERO)) THEN
9379 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9380 C DIBETA = SDIF1/STOT
9382 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9383 IF (DIBETA.LE.ZERO) THEN
9386 ALPGAM = DIALPH/DIGAMM
9390 FACDI = SQRT(FACDI1*FACDI2)
9391 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9403 BSITE( 0,IQ,NTARG,I) = ZERO
9404 BSITE(IE,IQ,NTARG,I) = ZERO
9423 FACN = ONE/DBLE(NSTATB)
9428 * initialize Gauss-integration for photon-proj.
9430 IF (IJPROJ.EQ.7) THEN
9431 IF (INTRGE(1).EQ.1) THEN
9432 AMLO2 = (3.0D0*AAM(13))**2
9433 ELSEIF (INTRGE(1).EQ.2) THEN
9438 IF (INTRGE(2).EQ.1) THEN
9440 ELSEIF (INTRGE(2).EQ.2) THEN
9445 AMHI20 = (ECMNN(IE)-AMP)**2
9446 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9447 XAMLO = LOG( AMLO2+Q2 )
9448 XAMHI = LOG( AMHI2+Q2 )
9450 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9452 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9455 * ratio direct/total photon-nucleon xsection
9456 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9459 * read pre-initialized profile-function from file
9460 IF (IOGLB.EQ.1) THEN
9461 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9462 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9463 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9464 & NA,NB,NSTATB,NSITEB
9465 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9466 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9467 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
9470 IF (LFIRST) WRITE(LOUT,1001) CFILE
9471 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9473 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9474 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9475 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9476 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9477 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9478 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9479 NLINES = INT(DBLE(NSITEB)/7.0D0)
9480 IF (NLINES.GT.0) THEN
9483 READ(LDAT,'(7E11.4)')
9484 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9488 IF (ISTART.LE.NSITEB) THEN
9489 READ(LDAT,'(7E11.4)')
9490 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9494 * variable projectile/target/energy runs:
9495 * read pre-initialized profile-functions from file
9496 ELSEIF (IOGLB.EQ.100) THEN
9497 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9501 * cross sections averaged over NSTATB nucleon configurations
9503 C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9513 IF (NIDX.LE.-1) THEN
9514 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9515 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9516 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9517 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9518 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9521 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9522 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9523 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9524 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9525 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9529 * integration over impact parameter B
9540 B = DBLE(IB)*BSTEP(NTARG)
9541 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
9543 * integration over M_V^2 for photon-proj.
9549 IF (IJPROJ.EQ.7) THEN
9561 IF (IJPROJ.EQ.7) THEN
9562 AMV2 = EXP(ABSZX(IM))-Q2
9564 IF (AMV2.LT.16.0D0) THEN
9566 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9571 * define M_V dependent properties of nucleon scattering amplitude
9572 * V_M-nucleon xsection
9573 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9574 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9575 * slope-parametrisation a la Kaidalov
9576 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9577 & +0.25D0*LOG(S/(AMV2+Q2)))
9579 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9580 * integration weight factor
9581 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9582 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9584 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9586 IF (IJPROJ.EQ.7) THEN
9587 RCA = GAM*SIGMV/TWOPI
9589 RCA = GAM*SIGSH/TWOPI
9592 CA = DCMPLX(RCA,FCA)
9601 * photon-projectile: check for supression by coherence length
9602 IF (IJPROJ.EQ.7) THEN
9603 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9607 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9613 X11 = B+COOT1(1,INB)-COOP1(1,INA)
9614 Y11 = COOT1(2,INB)-COOP1(2,INA)
9615 XY11 = GAM*(X11*X11+Y11*Y11)
9616 IF (XY11.LE.15.0D0) THEN
9617 C = CONE-CA*EXP(-XY11)
9618 AR = DBLE(PP11(INT1))
9619 AI = DIMAG(PP11(INT1))
9620 IF (ABS(AR).LT.TINY25) AR = ZERO
9621 IF (ABS(AI).LT.TINY25) AI = ZERO
9622 PP11(INT1) = DCMPLX(AR,AI)
9623 PP11(INT1) = PP11(INT1)*C
9626 SHI = SHI+LOG(AR*AR+AI*AI)
9628 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9629 X12 = B+COOT2(1,INB)-COOP1(1,INA)
9630 Y12 = COOT2(2,INB)-COOP1(2,INA)
9631 XY12 = GAM*(X12*X12+Y12*Y12)
9632 IF (XY12.LE.15.0D0) THEN
9633 C = CONE-CA*EXP(-XY12)
9634 AR = DBLE(PP12(INT2))
9635 AI = DIMAG(PP12(INT2))
9636 IF (ABS(AR).LT.TINY25) AR = ZERO
9637 IF (ABS(AI).LT.TINY25) AI = ZERO
9638 PP12(INT2) = DCMPLX(AR,AI)
9639 PP12(INT2) = PP12(INT2)*C
9641 X21 = B+COOT1(1,INB)-COOP2(1,INA)
9642 Y21 = COOT1(2,INB)-COOP2(2,INA)
9643 XY21 = GAM*(X21*X21+Y21*Y21)
9644 IF (XY21.LE.15.0D0) THEN
9645 C = CONE-CA*EXP(-XY21)
9646 AR = DBLE(PP21(INT1))
9647 AI = DIMAG(PP21(INT1))
9648 IF (ABS(AR).LT.TINY25) AR = ZERO
9649 IF (ABS(AI).LT.TINY25) AI = ZERO
9650 PP21(INT1) = DCMPLX(AR,AI)
9651 PP21(INT1) = PP21(INT1)*C
9653 X22 = B+COOT2(1,INB)-COOP2(1,INA)
9654 Y22 = COOT2(2,INB)-COOP2(2,INA)
9655 XY22 = GAM*(X22*X22+Y22*Y22)
9656 IF (XY22.LE.15.0D0) THEN
9657 C = CONE-CA*EXP(-XY22)
9658 AR = DBLE(PP22(INT2))
9659 AI = DIMAG(PP22(INT2))
9660 IF (ABS(AR).LT.TINY25) AR = ZERO
9661 IF (ABS(AI).LT.TINY25) AI = ZERO
9662 PP22(INT2) = DCMPLX(AR,AI)
9663 PP22(INT2) = PP22(INT2)*C
9674 IF (PP11(K).EQ.CZERO) THEN
9678 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9679 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9682 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9683 OMPP11 = OMPP11+AVDIPP
9684 C OMPP11 = OMPP11+(CONE-PP11(K))
9685 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9686 DIPP11 = DIPP11+AVDIPP
9687 IF (PP21(K).EQ.CZERO) THEN
9691 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9692 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9695 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9696 OMPP21 = OMPP21+AVDIPP
9697 C OMPP21 = OMPP21+(CONE-PP21(K))
9698 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9699 DIPP21 = DIPP21+AVDIPP
9706 IF (PP12(K).EQ.CZERO) THEN
9710 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9711 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9714 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9715 OMPP12 = OMPP12+AVDIPP
9716 C OMPP12 = OMPP12+(CONE-PP12(K))
9717 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9718 DIPP12 = DIPP12+AVDIPP
9719 IF (PP22(K).EQ.CZERO) THEN
9723 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9724 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9727 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9728 OMPP22 = OMPP22+AVDIPP
9729 C OMPP22 = OMPP22+(CONE-PP22(K))
9730 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9731 DIPP22 = DIPP22+AVDIPP
9734 SPROM = ONE-EXP(SHI)
9735 SPROB = SPROB+FACM*SPROM
9736 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9737 STOTM = DBLE(OMPP11+OMPP22)
9738 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9739 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9740 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9741 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9742 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9743 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9744 STOTB = STOTB+FACM*STOTM
9745 SELAB = SELAB+FACM*SELAM
9746 SDELB = SDELB+FACM*SDELM
9748 SQEPB = SQEPB+FACM*SQEPM
9749 SDQEB = SDQEB+FACM*SDQEM
9751 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9752 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9753 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9758 STOTN = STOTN+FACB*STOTB
9759 SELAN = SELAN+FACB*SELAB
9760 SQEPN = SQEPN+FACB*SQEPB
9761 SQETN = SQETN+FACB*SQETB
9762 SQE2N = SQE2N+FACB*SQE2B
9763 SPRON = SPRON+FACB*SPROB
9764 SDELN = SDELN+FACB*SDELB
9765 SDQEN = SDQEN+FACB*SDQEB
9767 IF (IJPROJ.EQ.7) THEN
9768 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9770 IF (DIBETA.GT.ZERO) THEN
9771 BPROD(IB+1)= BPROD(IB+1)
9772 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9774 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9780 STOT = STOT +FACN*STOTN
9781 STOT2 = STOT2+FACN*STOTN**2
9782 SELA = SELA +FACN*SELAN
9783 SELA2 = SELA2+FACN*SELAN**2
9784 SQEP = SQEP +FACN*SQEPN
9785 SQEP2 = SQEP2+FACN*SQEPN**2
9786 SQET = SQET +FACN*SQETN
9787 SQET2 = SQET2+FACN*SQETN**2
9788 SQE2 = SQE2 +FACN*SQE2N
9789 SQE22 = SQE22+FACN*SQE2N**2
9790 SPRO = SPRO +FACN*SPRON
9791 SPRO2 = SPRO2+FACN*SPRON**2
9792 SDEL = SDEL +FACN*SDELN
9793 SDEL2 = SDEL2+FACN*SDELN**2
9794 SDQE = SDQE +FACN*SDQEN
9795 SDQE2 = SDQE2+FACN*SDQEN**2
9799 * final cross sections
9801 XSTOT(IE,IQ,NTARG) = STOT
9803 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9805 XSELA(IE,IQ,NTARG) = SELA
9806 * 3) quasi-el.: A+B-->A+X (excluding 2)
9807 XSQEP(IE,IQ,NTARG) = SQEP
9808 * 4) quasi-el.: A+B-->X+B (excluding 2)
9809 XSQET(IE,IQ,NTARG) = SQET
9810 * 5) quasi-el.: A+B-->X (excluding 2-4)
9811 XSQE2(IE,IQ,NTARG) = SQE2
9812 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9813 IF (SDEL.GT.ZERO) THEN
9814 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9816 XSPRO(IE,IQ,NTARG) = SPRO
9818 * 7) projectile diffraction (el. scatt. off target)
9819 XSDEL(IE,IQ,NTARG) = SDEL
9820 * 8) projectile diffraction (quasi-el. scatt. off target)
9821 XSDQE(IE,IQ,NTARG) = SDQE
9823 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9824 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9825 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9826 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9827 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9828 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9829 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9830 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9832 IF (IJPROJ.EQ.7) THEN
9833 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9834 & -XSQEP(IE,IQ,NTARG)
9836 BNORM = XSPRO(IE,IQ,NTARG)
9839 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9840 IF ((IE.EQ.1).AND.(IQ.EQ.1))
9841 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9844 * write profile function data into file
9845 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9846 WRITE(LDAT,'(5I10,1P,E15.5)')
9847 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9848 WRITE(LDAT,'(1P,6E12.5)')
9849 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9850 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9851 WRITE(LDAT,'(1P,6E12.5)')
9852 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9853 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9854 NLINES = INT(DBLE(NSITEB)/7.0D0)
9855 IF (NLINES.GT.0) THEN
9858 WRITE(LDAT,'(1P,7E11.4)')
9859 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9863 IF (ISTART.LE.NSITEB) THEN
9864 WRITE(LDAT,'(1P,7E11.4)')
9865 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9871 C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9876 *$ CREATE DT_GETBXS.FOR
9879 *===getbxs=============================================================*
9881 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9883 ************************************************************************
9884 * Biasing in impact parameter space. *
9885 * XSFRAC = 0 : BLO - minimum impact parameter (input) *
9886 * BHI - maximum impact parameter (input) *
9887 * XSFRAC - fraction of cross section corresponding *
9888 * to impact parameter range (BLO,BHI) *
9890 * XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
9891 * BHI - maximum impact parameter giving requested *
9892 * fraction of cross section in impact *
9893 * parameter range (0,BMAX) (output) *
9894 * This version dated 17.03.00 is written by S. Roesler *
9895 ************************************************************************
9897 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9899 PARAMETER ( LINP = 10 ,
9903 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9904 * Glauber formalism: parameters
9905 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9906 & BMAX(NCOMPX),BSTEP(NCOMPX),
9907 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9911 IF (XSFRAC.LE.0.0D0) THEN
9912 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9913 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9914 IF (ILO.GE.IHI) THEN
9918 IF (ILO.EQ.NSITEB-1) THEN
9919 FRCLO = BSITE(0,1,NTARG,NSITEB)
9921 FRCLO = BSITE(0,1,NTARG,ILO+1)
9922 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9923 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9925 IF (IHI.EQ.NSITEB-1) THEN
9926 FRCHI = BSITE(0,1,NTARG,NSITEB)
9928 FRCHI = BSITE(0,1,NTARG,IHI+1)
9929 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9930 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9932 XSFRAC = FRCHI-FRCLO
9937 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9938 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
9939 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9940 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9950 *$ CREATE DT_CONUCL.FOR
9953 *===conucl=============================================================*
9955 SUBROUTINE DT_CONUCL(X,N,R,MODE)
9957 ************************************************************************
9958 * Calculation of coordinates of nucleons within nuclei. *
9959 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
9960 * N / R number of nucleons / radius of nucleus (input) *
9961 * MODE = 0 coordinates not sorted *
9962 * = 1 coordinates sorted with increasing X(3,i) *
9963 * = 2 coordinates sorted with decreasing X(3,i) *
9964 * This version dated 26.10.95 is revised by S. Roesler *
9965 ************************************************************************
9967 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9969 PARAMETER ( LINP = 10 ,
9973 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9974 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
9976 PARAMETER (TWOPI = 6.283185307179586454D+00 )
9979 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
9980 DIMENSION X(3,N),XTMP(3,260)
9982 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
9984 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
9993 DO 2 J=1,ICSRT(ISRT)
9995 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
9996 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
9997 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
9999 IF (ICSRT(ISRT).GT.1) THEN
10002 CALL DT_SORT(X,N,I0,I1,MODE)
10005 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10011 CALL DT_SORT(X,N,1,N,MODE)
10023 *$ CREATE DT_COORDI.FOR
10026 *===coordi=============================================================*
10028 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10030 ************************************************************************
10031 * Calculation of coordinates of nucleons within nuclei. *
10032 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
10033 * N / R number of nucleons / radius of nucleus (input) *
10034 * Based on the original version by Shmakov et al. *
10035 * This version dated 26.10.95 is revised by S. Roesler *
10036 ************************************************************************
10038 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10040 PARAMETER ( LINP = 10 ,
10044 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10045 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10047 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10051 PARAMETER (NSRT=10)
10052 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10053 DIMENSION X(3,260),WD(4),RD(3)
10055 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10056 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10057 DATA RD /2.09D0, 0.935D0, 0.697D0/
10067 ELSEIF (N.EQ.2) THEN
10068 EPS = DT_RNDM(RD(1))
10070 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10074 CALL DT_RANNOR(X1,X2)
10078 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10081 CALL DT_RANNOR(X3,X4)
10083 CALL DT_RANNOR(X1,X2)
10086 IF (LSTART) GOTO 80
10088 CALL DT_RANNOR(X3,X4)
10093 LSTART = .NOT.LSTART
10094 X1SUM = X1SUM+X(1,I)
10095 X2SUM = X2SUM+X(2,I)
10096 X3SUM = X3SUM+X(3,I)
10098 X1SUM = X1SUM/DBLE(N)
10099 X2SUM = X2SUM/DBLE(N)
10100 X3SUM = X3SUM/DBLE(N)
10102 X(1,I) = X(1,I)-X1SUM
10103 X(2,I) = X(2,I)-X2SUM
10104 X(3,I) = X(3,I)-X3SUM
10108 * maximum nuclear radius for coordinate sampling
10109 RMAX = R+4.605D0*PDIF
10111 * initialize pre-sorting
10115 DR = TWO*RMAX/DBLE(NSRT)
10117 * sample coordinates for N nucleons
10120 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10121 F = DT_DENSIT(N,RAD,R)
10122 IF (DT_RNDM(RAD).GT.F) GOTO 120
10123 * theta, phi uniformly distributed
10124 CT = ONE-TWO*DT_RNDM(F)
10125 ST = SQRT((ONE-CT)*(ONE+CT))
10126 CALL DT_DSFECF(SFE,CFE)
10127 X(1,I) = RAD*ST*CFE
10128 X(2,I) = RAD*ST*SFE
10130 * ensure that distance between two nucleons is greater than R2MIN
10131 IF (I.LT.2) GOTO 122
10134 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10135 & (X(3,I)-X(3,I2))**2
10136 IF (DIST2.LE.R2MIN) GOTO 120
10139 * save index according to z-bin
10140 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10141 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10142 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10143 X1SUM = X1SUM+X(1,I)
10144 X2SUM = X2SUM+X(2,I)
10145 X3SUM = X3SUM+X(3,I)
10147 X1SUM = X1SUM/DBLE(N)
10148 X2SUM = X2SUM/DBLE(N)
10149 X3SUM = X3SUM/DBLE(N)
10151 X(1,I) = X(1,I)-X1SUM
10152 X(2,I) = X(2,I)-X2SUM
10153 X(3,I) = X(3,I)-X3SUM
10161 *$ CREATE DT_DENSIT.FOR
10164 *===densit=============================================================*
10166 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10168 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10171 PARAMETER ( LINP = 10 ,
10174 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10175 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10178 DIMENSION R0(18),FNORM(18)
10179 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10180 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10181 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10182 & 2.72D0, 2.66D0, 2.79D0/
10183 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10184 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10185 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10186 & .1214D+01,.1265D+01,.1318D+01/
10187 DATA PDIF /0.545D0/
10193 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10194 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10195 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10196 & *EXP(-(R/R1)**2)/FNORM(NA)
10198 ELSEIF (NA.GT.18) THEN
10199 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10205 *$ CREATE DT_RNCLUS.FOR
10208 *===rnclus=============================================================*
10210 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10212 ************************************************************************
10213 * Nuclear radius for nucleus with mass number N. *
10214 * This version dated 26.9.00 is written by S. Roesler *
10215 ************************************************************************
10217 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10220 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10223 PARAMETER (RNUCLE = 1.12D0)
10225 * nuclear radii for selected nuclei
10226 DIMENSION RADNUC(18)
10227 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10228 & 2.58D0,2.71D0,2.66D0,2.71D0/
10231 IF (RADNUC(N).GT.0.0D0) THEN
10232 DT_RNCLUS = RADNUC(N)
10234 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10237 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10243 *$ CREATE DT_DENTST.FOR
10246 *===dentst=============================================================*
10248 C PROGRAM DT_DENTST
10249 SUBROUTINE DT_DENTST
10251 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10254 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10255 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10260 DR = (RMAX-RMIN)/DBLE(NBINS)
10264 R = RMIN+DBLE(IR-1)*DR
10265 F = DT_DENSIT(IA,R,R)
10266 IF (F.GT.FMAX) FMAX = F
10267 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10269 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10277 *$ CREATE DT_SHMAKI.FOR
10280 *===shmaki=============================================================*
10282 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10284 ************************************************************************
10285 * Initialisation of Glauber formalism. This subroutine has to be *
10286 * called once (in case of target emulsions as often as many different *
10287 * target nuclei are considered) before events are sampled. *
10288 * NA / NCA mass number/charge of projectile nucleus *
10289 * NB / NCB mass number/charge of target nucleus *
10290 * IJP identity of projectile (hadrons/leptons/photons) *
10291 * PPN projectile momentum (for projectile nuclei: *
10292 * momentum per nucleon) in target rest system *
10293 * MODE = 0 Glauber formalism invoked *
10294 * = 1 fitted results are loaded from data-file *
10295 * = 99 NTARG is forced to be 1 *
10296 * (used in connection with GLAUBERI-card only) *
10297 * This version dated 22.03.96 is based on the original SHMAKI-routine *
10298 * and revised by S. Roesler. *
10299 ************************************************************************
10301 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10303 PARAMETER ( LINP = 10 ,
10306 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10309 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10310 * Glauber formalism: parameters
10311 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10312 & BMAX(NCOMPX),BSTEP(NCOMPX),
10313 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10315 * Lorentz-parameters of the current interaction
10316 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10317 & UMO,PPCM,EPROJ,PPROJ
10318 * properties of photon/lepton projectiles
10319 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10320 * kinematical cuts for lepton-nucleus interactions
10321 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10322 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10323 * Glauber formalism: cross sections
10324 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10325 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10326 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10327 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10328 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10329 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10330 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10331 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10332 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10333 & BSLOPE,NEBINI,NQBINI
10334 * cuts for variable energy runs
10335 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10336 * nucleon-nucleon event-generator
10339 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10340 * Glauber formalism: flags and parameters for statistics
10343 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10345 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10351 IF (MODE.EQ.99) NTARG = 1
10353 IF (MODE.EQ.-1) NIDX = NTARG
10355 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10356 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10357 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10358 & ' initialization',/,12X,'--------------------------',
10359 & '-------------------------',/)
10361 IF (MODE.EQ.2) THEN
10362 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10363 CALL DT_SHFAST(MODE,PPN,IBACK)
10364 STOP ' Glauber pre-initialization done'
10366 IF (MODE.EQ.1) THEN
10367 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10370 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10371 IF (IBACK.EQ.1) THEN
10372 * lepton-nucleus (variable energy runs)
10373 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10374 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10375 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10376 & WRITE(LOUT,1002) NB,NCB
10377 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10378 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10379 & 'E_cm (GeV) Q^2 (GeV^2)',
10380 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10381 & '--------------------------------',
10382 & '------------------------------')
10383 AECMLO = LOG10(MIN(UMO,ECMLI))
10384 AECMHI = LOG10(MIN(UMO,ECMHI))
10386 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10387 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10389 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10390 IF (Q2HI.GT.0.1D0) THEN
10391 IF (Q2LI.LT.0.01D0) THEN
10392 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10393 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10395 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10402 AQ2LO = LOG10(Q2LI)
10403 AQ2HI = LOG10(Q2HI)
10404 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10405 DO 2 J=IBIN,IQSTEP+IBIN
10406 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10407 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10408 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10409 & WRITE(LOUT,1003) ECMNN(I),
10410 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10413 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10414 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10416 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10418 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10422 * hadron/photon/nucleus-nucleus
10423 IF ((ABS(VAREHI).GT.ZERO).AND.
10424 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10425 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10426 WRITE(LOUT,1004) NA,NB,NCB
10427 1004 FORMAT(1X,'variable energy run: projectile-id:',
10428 & I3,' target A/Z: ',I3,' /',I3,/)
10430 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10431 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10432 & ' -------------------------------------',
10433 & '--------------------------------------')
10435 AECMLO = LOG10(VARCLO)
10436 AECMHI = LOG10(VARCHI)
10438 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10439 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10441 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10446 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10447 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10448 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10449 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10451 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10452 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10456 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10462 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10463 & (IOGLB.NE.100)) THEN
10464 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10465 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10466 1001 FORMAT(38X,'projectile',
10467 & ' target',/,1X,'Mass number / charge',
10468 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10469 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10470 & 'Parameters of elastic scattering amplitude:',/,5X,
10471 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10472 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10473 & 'statistics at each b-step',4X,I5,/,/,1X,
10474 & 'Prod. cross section ',5X,F10.4,' mb',/)
10480 *$ CREATE DT_PROFBI.FOR
10483 *===profbi=============================================================*
10485 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10487 ************************************************************************
10488 * Integral over profile function (to be used for impact-parameter *
10489 * sampling during event generation). *
10490 * Fitted results are used. *
10491 * NA / NB mass numbers of proj./target nuclei *
10492 * PPN projectile momentum (for projectile nuclei: *
10493 * momentum per nucleon) in target rest system *
10494 * NTARG index of target material (i.e. kind of nucleus) *
10495 * This version dated 31.05.95 is revised by S. Roesler *
10496 ************************************************************************
10498 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10500 PARAMETER ( LINP = 10 ,
10505 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10510 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10511 * Glauber formalism: parameters
10512 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10513 & BMAX(NCOMPX),BSTEP(NCOMPX),
10514 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10516 * Glauber formalism: cross sections
10517 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10518 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10519 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10520 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10521 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10522 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10523 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10524 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10525 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10526 & BSLOPE,NEBINI,NQBINI
10528 PARAMETER (NGLMAX=8000)
10529 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10530 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10532 DATA LSTART /.TRUE./
10535 * read fit-parameters from file
10536 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10539 READ(47,'(A80)') CNAME
10540 IF (CNAME.EQ.'STOP') GOTO 2
10542 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10543 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10544 & GLAFIT(4,I),GLAFIT(5,I)
10545 IF (I+1.GT.NGLMAX) THEN
10547 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
10548 & 'program stopped')
10565 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10566 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10569 IF (J.EQ.NGLPAR) IPOINT = J+1-K
10570 IF ((NNA.GT.NGLIP(IPOINT)).OR.
10571 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10572 IF (IPOINT.EQ.1) IPOINT = 0
10573 NATMP = NGLIP(IPOINT+1)
10574 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10580 C IF (J.EQ.NGLPAR) THEN
10584 DO 5 J1=J1BEG,J1END
10585 IF (NGLIP(J1).EQ.NATMP) THEN
10586 IF (PPN.LT.GLAPPN(J1)) THEN
10595 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10604 IF (IDXGLA.EQ.0) THEN
10605 WRITE(LOUT,1001) NNA,NNB,PPN
10606 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
10607 & 2I4,F6.0,') not found ')
10611 * no interpolation yet available
10612 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10614 BSITE(1,1,NTARG,1) = ZERO
10617 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10618 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10619 & GLAFIT(5,IDXGLA)*XX**4
10620 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10621 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10622 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10628 *$ CREATE DT_GLAUBE.FOR
10631 *===glaube=============================================================*
10633 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10635 ************************************************************************
10636 * Calculation of configuartion of interacting nucleons for one event. *
10637 * NB / NB mass numbers of proj./target nuclei (input) *
10638 * B impact parameter (output) *
10639 * INTT total number of wounded nucleons " *
10640 * INTA / INTB number of wounded nucleons in proj. / target " *
10641 * JS / JT(i) number of collisions proj. / target nucleon i is *
10642 * involved (output) *
10643 * NIDX index of projectile/target material (input) *
10644 * = -2 call within FLUKA transport calculation *
10645 * This is an update of the original routine SHMAKO by J.Ranft/HJM *
10646 * This version dated 22.03.96 is revised by S. Roesler *
10648 * Last change 27.12.2006 by S. Roesler. *
10649 ************************************************************************
10651 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10653 PARAMETER ( LINP = 10 ,
10656 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10657 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10659 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10660 PARAMETER ( MAXNCL = 260,
10662 & MAXSQU = 20*MAXVQU,
10663 & MAXINT = MAXVQU+MAXSQU)
10664 * Glauber formalism: parameters
10665 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10666 & BMAX(NCOMPX),BSTEP(NCOMPX),
10667 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10669 * Glauber formalism: cross sections
10670 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10671 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10672 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10673 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10674 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10675 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10676 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10677 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10678 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10679 & BSLOPE,NEBINI,NQBINI
10680 * Lorentz-parameters of the current interaction
10681 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10682 & UMO,PPCM,EPROJ,PPROJ
10683 * properties of photon/lepton projectiles
10684 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10685 * Glauber formalism: collision properties
10686 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10687 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10688 * Glauber formalism: flags and parameters for statistics
10691 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10693 DIMENSION JS(MAXNCL),JT(MAXNCL)
10697 * get actual energy from /DTLTRA/
10701 * new patch for pre-initialized variable projectile/target/energy runs,
10702 * bypassed for use within FLUKA (Nidx=-2)
10703 IF (IOGLB.EQ.100) THEN
10704 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10706 * variable energy run, interpolate profile function
10711 IF (NEBINI.GT.1) THEN
10712 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10716 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10718 IF (ECMNOW.LT.ECMNN(I)) THEN
10721 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10731 IF (NQBINI.GT.1) THEN
10732 IF (Q2.GE.Q2G(NQBINI)) THEN
10736 ELSEIF (Q2.GT.Q2G(1)) THEN
10738 IF (Q2.LT.Q2G(I)) THEN
10741 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
10742 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10743 C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10752 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10753 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10754 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10755 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10756 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10760 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10761 IF (NIDX.LE.-1) THEN
10763 RTARG = RBSH(NTARG)
10765 RPROJ = RASH(NTARG)
10772 *$ CREATE DT_DIAGR.FOR
10775 *===diagr==============================================================*
10777 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10780 ************************************************************************
10781 * Based on the original version by Shmakov et al. *
10782 * This version dated 21.04.95 is revised by S. Roesler *
10783 ************************************************************************
10785 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10787 PARAMETER ( LINP = 10 ,
10790 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10791 PARAMETER (TWOPI = 6.283185307179586454D+00,
10793 & GEV2MB = 0.38938D0,
10794 & GEV2FM = 0.1972D0,
10795 & ALPHEM = ONE/137.0D0,
10803 PARAMETER ( MAXNCL = 260,
10805 & MAXSQU = 20*MAXVQU,
10806 & MAXINT = MAXVQU+MAXSQU)
10807 * particle properties (BAMJET index convention)
10809 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10810 & IICH(210),IIBAR(210),K1(210),K2(210)
10811 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10812 * emulsion treatment
10813 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10815 * Glauber formalism: parameters
10816 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10817 & BMAX(NCOMPX),BSTEP(NCOMPX),
10818 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10820 * Glauber formalism: cross sections
10821 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10822 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10823 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10824 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10825 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10826 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10827 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10828 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10829 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10830 & BSLOPE,NEBINI,NQBINI
10831 * VDM parameter for photon-nucleus interactions
10832 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10833 * nucleon-nucleon event-generator
10836 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10838 C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10840 C obsolete cut-off information
10841 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10842 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10844 * coordinates of nucleons
10845 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10846 * interface between Glauber formalism and DPM
10847 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10848 & INTER1(MAXINT),INTER2(MAXINT)
10849 * statistics: Glauber-formalism
10850 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10851 * n-n cross section fluctuations
10852 PARAMETER (NBINS = 1000)
10853 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10855 DIMENSION JS(MAXNCL),JT(MAXNCL),
10856 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10857 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10858 DIMENSION NWA(0:210),NWB(0:210)
10861 DATA LFIRST /.TRUE./
10863 DATA NTARGO,ICNT /0,0/
10869 IF (NCOMPO.EQ.0) THEN
10879 IF (NTARG.EQ.-1) THEN
10880 IF (NCOMPO.EQ.0) THEN
10881 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10882 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10883 & NCALL,NWAMAX,NWBMAX
10884 DO 18 I=1,MAX(NWAMAX,NWBMAX)
10885 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10886 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10887 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10897 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10899 X = SQ2/(S+SQ2-AMP2)
10900 XNU = (S+SQ2-AMP2)/(TWO*AMP)
10901 * photon projectiles: recalculate photon-nucleon amplitude
10902 IF (IJPROJ.EQ.7) THEN
10904 * VDM assumption: mass of V-meson
10905 AMV2 = DT_SAM2(SQ2,ECMNOW)
10907 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10908 * check for pointlike interaction
10909 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10911 C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10912 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10915 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10916 & +0.25D0*LOG(S/(AMV2+SQ2)))
10918 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10919 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10920 IF (MCGENE.EQ.2) THEN
10922 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10925 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10927 IF (ECMNOW.LE.3.0D0) THEN
10929 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10930 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10931 ELSEIF (ECMNOW.GT.50.0D0) THEN
10934 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10935 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10936 IF (MCGENE.EQ.2) THEN
10938 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10940 SIGSH = SIGSH/10.0D0
10942 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10944 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10945 SIGSH = SIGSH/10.0D0
10948 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10950 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10951 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10952 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10954 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10955 SIGSH = SIGSH/10.0D0
10957 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10959 RCA = GAM*SIGSH/TWOPI
10961 CA = DCMPLX(RCA,FCA)
10962 CI = DCMPLX(ONE,ZERO)
10966 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
10979 IF (IJPROJ.EQ.7) THEN
10989 * nucleon configuration
10990 C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
10991 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
10992 C CALL DT_CONUCL(PKOO,NA,RASH,2)
10993 C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
10994 IF (NIDX.LE.-1) THEN
10995 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
10996 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
10998 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
10999 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11005 * LEPTO: pick out one struck nucleon
11006 IF (MCGENE.EQ.3) THEN
11009 IDX = INT(DT_RNDM(X)*NB)+1
11016 * cross section fluctuations
11018 IF (IFLUCT.EQ.1) THEN
11019 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11020 AFLUC = FLUIXX(IFLUK)
11025 * photon-projectile: check for supression by coherence length
11026 IF (IJPROJ.EQ.7) THEN
11027 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11032 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11033 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11034 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11035 IF (XY.LE.15.0D0) THEN
11036 C = CI-CA*AFLUC*EXP(-XY)
11040 IF (DT_RNDM(XY).GE.P) THEN
11042 IF (IJPROJ.EQ.7) THEN
11043 JNT0(KINT) = JNT0(KINT)+1
11044 IF (JNT0(KINT).GT.MAXNCL) THEN
11045 WRITE(LOUT,1001) MAXNCL
11047 & 'DIAGR: no. of requested interactions',
11048 & ' exceeds array dimensions ',I4)
11051 JS0(KINT) = JS0(KINT)+1
11052 JT0(KINT,INB) = JT0(KINT,INB)+1
11053 JI1(KINT,JNT0(KINT)) = INA
11054 JI2(KINT,JNT0(KINT)) = INB
11056 IF (JNT.GT.MAXINT) THEN
11057 WRITE(LOUT,1000) JNT, MAXINT
11059 & 'DIAGR: no. of requested interactions ('
11060 & ,I4,') exceeds array dimensions (',I4,')')
11063 JS(INA) = JS(INA)+1
11064 JT(INB) = JT(INB)+1
11074 IF (NTRY.LT.500) THEN
11077 C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11083 IF (IJPROJ.EQ.7) THEN
11084 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11086 IF (JNT0(K).EQ.0) THEN
11088 IF (K.GT.KINT) K = 1
11091 * supress Glauber-cascade by direct photon processes
11092 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11093 IF (IPNT.GT.0) THEN
11097 JT(INB) = JT0(K,INB)
11098 IF (JT(INB).GT.0) GOTO 12
11108 JT(INB) = JT0(K,INB)
11111 INTER1(I) = JI1(K,I)
11112 INTER2(I) = JI2(K,I)
11121 IF (JS(I).NE.0) INTA=INTA+1
11124 IF (JT(I).NE.0) INTB=INTB+1
11133 IF (NCOMPO.EQ.0) THEN
11135 NWA(INTA) = NWA(INTA)+1
11136 NWB(INTB) = NWB(INTB)+1
11142 *$ CREATE DT_MODB.FOR
11145 *===modb===============================================================*
11147 SUBROUTINE DT_MODB(B,NIDX)
11149 ************************************************************************
11150 * Sampling of impact parameter of collision. *
11151 * B impact parameter (output) *
11152 * NIDX index of projectile/target material (input)*
11153 * Based on the original version by Shmakov et al. *
11154 * This version dated 21.04.95 is revised by S. Roesler *
11156 * Last change 27.12.2006 by S. Roesler. *
11157 ************************************************************************
11159 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11161 PARAMETER ( LINP = 10 ,
11164 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11166 LOGICAL LEFT,LFIRST
11168 * central particle production, impact parameter biasing
11169 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11170 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11171 * Glauber formalism: parameters
11172 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11173 & BMAX(NCOMPX),BSTEP(NCOMPX),
11174 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11176 * Glauber formalism: cross sections
11177 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11178 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11179 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11180 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11181 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11182 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11183 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11184 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11185 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11186 & BSLOPE,NEBINI,NQBINI
11188 DATA LFIRST /.TRUE./
11191 IF (NIDX.LE.-1) THEN
11199 IF (ICENTR.EQ.2) THEN
11201 BB = DT_RNDM(B)*(0.3D0*RA)**2
11203 ELSEIF(RA.LT.RB)THEN
11204 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11206 ELSEIF(RA.GT.RB)THEN
11207 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11217 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11218 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11225 IF (I2-I0-2) 40,50,60
11228 IF (I1.GT.NSITEB) I1 = I0-1
11236 X0 = DBLE(I0-1)*BSTEP(NTARG)
11237 X1 = DBLE(I1-1)*BSTEP(NTARG)
11238 X2 = DBLE(I2-1)*BSTEP(NTARG)
11239 Y0 = BSITE(0,1,NTARG,I0)
11240 Y1 = BSITE(0,1,NTARG,I1)
11241 Y2 = BSITE(0,1,NTARG,I2)
11243 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11244 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11245 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11246 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11247 B = B+0.5D0*BSTEP(NTARG)
11248 IF (B.LT.ZERO) B = X1
11249 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11250 IF (ICENTR.LT.0) THEN
11253 IF (ICENTR.LE.-100) THEN
11258 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11259 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11260 & BIMIN,BIMAX,XSFRAC*100.0D0,
11261 & XSFRAC*XSPRO(1,1,NTARG)
11262 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11263 & /,15X,'---------------------------'/,/,4X,
11264 & 'average radii of proj / targ :',F10.3,' fm /',
11265 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11266 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11267 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11268 & ' cross section :',F10.3,' %',/,5X,
11269 & 'corresponding cross section :',F10.3,' mb',/)
11271 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11274 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11282 *$ CREATE DT_SHFAST.FOR
11285 *===shfast=============================================================*
11287 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11289 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11291 PARAMETER ( LINP = 10 ,
11294 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11295 & ONE=1.0D0,TWO=2.0D0)
11297 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11298 * Glauber formalism: parameters
11299 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11300 & BMAX(NCOMPX),BSTEP(NCOMPX),
11301 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11303 * properties of interacting particles
11304 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11305 * Glauber formalism: cross sections
11306 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11307 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11308 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11309 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11310 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11311 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11312 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11313 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11314 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11315 & BSLOPE,NEBINI,NQBINI
11319 IF (MODE.EQ.2) THEN
11320 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11321 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11322 1000 FORMAT(1X,8I5,E15.5)
11323 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11324 1001 FORMAT(1X,4E15.5)
11325 WRITE(47,1002) SIGSH,ROSH,GSH
11326 1002 FORMAT(1X,3E15.5)
11328 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11330 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11331 1003 FORMAT(1X,2I10,3E15.5)
11334 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11335 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11336 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11337 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11338 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11339 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11340 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11341 READ(47,1002) SIGSH,ROSH,GSH
11343 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11345 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11355 *$ CREATE DT_POILIK.FOR
11358 *===poilik=============================================================*
11360 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11362 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11365 PARAMETER ( LINP = 10 ,
11368 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11372 C CHARACTER*8 MDLNA
11373 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11374 C PARAMETER (IEETAB=10)
11375 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11377 C model switches and parameters
11379 INTEGER ISWMDL,IPAMDL
11380 DOUBLE PRECISION PARMDL
11381 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11382 C energy-interpolation table
11384 PARAMETER ( IEETA2 = 20 )
11386 DOUBLE PRECISION SIGTAB,SIGECM
11387 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11389 * VDM parameter for photon-nucleus interactions
11390 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11392 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11393 * Glauber formalism: cross sections
11394 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11395 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11396 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11397 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11398 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11399 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11400 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11401 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11402 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11403 & BSLOPE,NEBINI,NQBINI
11406 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11408 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11410 * load cross sections from interpolation table
11412 IF(ECM.LE.SIGECM(IP,1)) THEN
11415 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11417 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11423 WRITE(LOUT,'(/1X,A,2E12.3)')
11424 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11429 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11430 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11433 SIGANO = DT_SANO(ECM)
11435 * cross section dependence on photon virtuality
11438 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11439 & /(ONE+VIRT/PARMDL(30+I))**2
11441 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11451 C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11452 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11453 IF (ISHAD(1).EQ.1) THEN
11454 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11458 SIGANO = FSUP1*FSUP2*SIGANO
11459 SIGTOT = SIGTOT-SIGDIR-SIGANO
11460 SIGDIR = SIGDIR/(FSUP1*FSUP2)
11461 SIGANO = SIGANO/(FSUP1*FSUP2)
11462 SIGTOT = SIGTOT+SIGDIR+SIGANO
11464 RR = DT_RNDM(SIGTOT)
11465 IF (RR.LT.SIGDIR/SIGTOT) THEN
11467 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11468 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11473 RPNT = (SIGDIR+SIGANO)/SIGTOT
11474 C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11475 C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11476 C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11477 C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11478 IF (MODE.EQ.1) RETURN
11484 IF (ECM.GE.ECMNN(NEBINI)) THEN
11488 ELSEIF (ECM.GT.ECMNN(1)) THEN
11490 IF (ECM.LT.ECMNN(I)) THEN
11493 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11502 IF (NQBINI.GT.1) THEN
11503 IF (VIRT.GE.Q2G(NQBINI)) THEN
11507 ELSEIF (VIRT.GT.Q2G(1)) THEN
11509 IF (VIRT.LT.Q2G(I)) THEN
11512 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
11513 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11520 SGA = XSPRO(K1,J1,NTARG)+
11521 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11522 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11523 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11524 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11525 SDI = DBLE(NB)*SIGDIR
11526 SAN = DBLE(NB)*SIGANO
11529 IF (RR.LT.SDI/SGA) THEN
11531 ELSEIF ((RR.GE.SDI/SGA).AND.
11532 & (RR.LT.SPL/SGA)) THEN
11538 C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11544 *$ CREATE DT_GLBINI.FOR
11547 *===glbini=============================================================*
11549 SUBROUTINE DT_GLBINI(WHAT)
11551 ************************************************************************
11552 * Pre-initialization of profile function *
11553 * This version dated 28.11.00 is written by S. Roesler. *
11555 * Last change 27.12.2006 by S. Roesler. *
11556 ************************************************************************
11558 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11561 PARAMETER ( LINP = 10 ,
11564 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11568 * particle properties (BAMJET index convention)
11570 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11571 & IICH(210),IIBAR(210),K1(210),K2(210)
11572 * properties of interacting particles
11573 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11574 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11575 * emulsion treatment
11576 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11578 * Glauber formalism: flags and parameters for statistics
11581 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11582 * number of data sets other than protons and nuclei
11583 * at the moment = 2 (pions and kaons)
11584 PARAMETER (MAXOFF=2)
11585 DIMENSION IJPINI(5),IOFFST(25)
11586 DATA IJPINI / 13, 15, 0, 0, 0/
11587 * Glauber data-set to be used for hadron projectiles
11588 * (0=proton, 1=pion, 2=kaon)
11589 DATA (IOFFST(K),K=1,25) /
11590 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11592 * Acceptance interval for target nucleus mass
11593 PARAMETER (KBACC = 6)
11594 * flags for input different options
11595 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11596 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11597 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11599 PARAMETER (MAXMSS = 100)
11600 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11603 DATA JPEACH,JPSTEP / 18, 5 /
11605 * temporary patch until fix has been implemented in phojet:
11606 * maximum energy for pion projectile
11607 DATA ECMXPI / 100000.0D0 /
11609 *--------------------------------------------------------------------------
11610 * general initializations
11612 * steps in projectile mass number for initialization
11613 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11614 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11616 * energy range and binning
11619 IF (ELO.GT.EHI) ELO = EHI
11620 NEBIN = MAX(INT(WHAT(3)),1)
11621 IF (ELO.EQ.EHI) NEBIN = 0
11622 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11626 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11627 & +2.0D0*AAM(IJTARG)*EHI)
11630 * default arguments for Glauber-routine
11634 * initialize nuclear parameters, etc.
11638 * open Glauber-data output file
11639 IDX = INDEX(CGLB,' ')
11641 IF (IDX.GT.1) K = IDX-1
11642 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11644 *--------------------------------------------------------------------------
11645 * Glauber-initialization for proton and nuclei projectiles
11647 * initialize phojet for proton-proton interactions
11650 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11653 * record projectile masses
11655 NPROJ = MIN(IP,JPEACH)
11656 DO 10 KPROJ=1,NPROJ
11658 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11659 IASAV(NASAV) = KPROJ
11661 IF (IP.GT.JPEACH) THEN
11662 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11663 IF (NPROJ.EQ.0) THEN
11665 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11668 DO 11 IPROJ=1,NPROJ
11669 KPROJ = JPEACH+IPROJ*JPSTEP
11671 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11672 IASAV(NASAV) = KPROJ
11674 IF (KPROJ.LT.IP) THEN
11676 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11682 * record target masses
11685 IF (NCOMPO.GT.0) NTARG = NCOMPO
11686 DO 12 ITARG=1,NTARG
11688 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11689 IF (NCOMPO.GT.0) THEN
11690 IBSAV(NBSAV) = IEMUMA(ITARG)
11697 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11698 1000 FORMAT(I4,A,1P,2E13.5)
11699 NLINES = DBLE(NASAV)/18.0D0
11700 IF (NLINES.GT.0) THEN
11703 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11705 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11710 IF (I0.LE.NASAV) THEN
11712 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11714 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11717 NLINES = DBLE(NBSAV)/18.0D0
11718 IF (NLINES.GT.0) THEN
11721 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11723 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11728 IF (I0.LE.NBSAV) THEN
11730 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11732 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11736 * calculate Glauber-data for each energy and mass combination
11738 * loop over energy bins
11741 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11743 E = ELO+DBLE(IE-1)*DEBIN
11746 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11751 E = MAX(AAM(IJPROJ)+0.1D0,E)
11752 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11755 * loop over projectile and target masses
11758 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11759 & XI,Q2I,ECM,1,1,-1)
11765 *--------------------------------------------------------------------------
11766 * Glauber-initialization for pion, kaon, ... projectiles
11770 * initialize phojet for this interaction
11773 IJPROJ = IJPINI(IJ)
11777 * temporary patch until fix has been implemented in phojet:
11778 IF (ECMINI.GT.ECMXPI) THEN
11779 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11781 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11785 * calculate Glauber-data for each energy and mass combination
11787 * loop over energy bins
11789 E = ELO+DBLE(IE-1)*DEBIN
11792 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11797 E = MAX(AAM(IJPROJ)+TINY14,E)
11798 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11801 * loop over projectile and target masses
11803 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11810 *--------------------------------------------------------------------------
11811 * close output unit(s), etc.
11818 *$ CREATE DT_GLBSET.FOR
11821 *===glbset=============================================================*
11823 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11824 ************************************************************************
11825 * Interpolation of pre-initialized profile functions *
11826 * This version dated 28.11.00 is written by S. Roesler. *
11827 ************************************************************************
11829 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11832 PARAMETER ( LINP = 10 ,
11835 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11837 LOGICAL LCMS,LREAD,LFRST1,LFRST2
11839 * particle properties (BAMJET index convention)
11841 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11842 & IICH(210),IIBAR(210),K1(210),K2(210)
11843 * Glauber formalism: flags and parameters for statistics
11846 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11847 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11848 * Glauber formalism: parameters
11849 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11850 & BMAX(NCOMPX),BSTEP(NCOMPX),
11851 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11853 * Glauber formalism: cross sections
11854 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11855 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11856 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11857 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11858 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11859 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11860 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11861 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11862 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11863 & BSLOPE,NEBINI,NQBINI
11864 * number of data sets other than protons and nuclei
11865 * at the moment = 2 (pions and kaons)
11866 PARAMETER (MAXOFF=2)
11867 DIMENSION IJPINI(5),IOFFST(25)
11868 DATA IJPINI / 13, 15, 0, 0, 0/
11869 * Glauber data-set to be used for hadron projectiles
11870 * (0=proton, 1=pion, 2=kaon)
11871 DATA (IOFFST(K),K=1,25) /
11872 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11874 * Acceptance interval for target nucleus mass
11875 PARAMETER (KBACC = 6)
11876 * emulsion treatment
11877 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11880 PARAMETER (MAXSET=5000,
11882 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11883 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11884 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11887 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11889 * read data from file
11891 IF (MODE.EQ.0) THEN
11914 IDX = INDEX(CGLB,' ')
11916 IF (IDX.GT.1) K = IDX-1
11917 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11918 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11919 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
11922 * read binning information
11923 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11924 * return lower energy threshold to Fluka-interface
11927 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11929 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11931 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11933 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
11934 & 'No. of bins:',I5,/)
11935 ELO = LOG10(ABS(ELO))
11936 EHI = LOG10(ABS(EHI))
11937 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11938 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11939 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11940 IF (NABIN.LT.18) THEN
11941 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11943 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11945 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11946 IF (NABIN.GT.18) THEN
11947 NLINES = DBLE(NABIN-18)/18.0D0
11948 IF (NLINES.GT.0) THEN
11951 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11952 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11955 I0 = 18*(NLINES+1)+1
11956 IF (I0.LE.NABIN) THEN
11957 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11958 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11961 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11962 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11963 IF (NBBIN.LT.18) THEN
11964 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
11966 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
11968 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
11969 IF (NBBIN.GT.18) THEN
11970 NLINES = DBLE(NBBIN-18)/18.0D0
11971 IF (NLINES.GT.0) THEN
11974 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
11975 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
11978 I0 = 18*(NLINES+1)+1
11979 IF (I0.LE.NBBIN) THEN
11980 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
11981 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
11984 * number of data sets to follow in the Glauber data file
11985 * this variable is used for checks of consistency of projectile
11986 * and target mass configurations given in header of Glauber data
11987 * file and the data-sets which follow in this file
11988 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
11990 * read profile function data
11996 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
11997 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
11998 1002 FORMAT(5I10,E15.5)
11999 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12001 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12005 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12006 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12007 NLINES = INT(DBLE(ISITEB)/7.0D0)
12008 IF (NLINES.GT.0) THEN
12010 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12015 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12019 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12020 WRITE(LOUT,'(/,1X,A)')
12021 & ' projectiles other than protons and nuclei: (particle index)'
12022 IF (NAIDX.GT.0) THEN
12023 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12025 WRITE(LOUT,'(6X,A)') 'none'
12032 IF (NCOMPO.EQ.0) THEN
12035 IEMUMA(NCOMPO) = IBBIN(J)
12036 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12037 EMUFRA(NCOMPO) = 1.0D0
12042 * calculate profile function for certain set of parameters
12046 c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12048 * check for type of projectile and set index-offset to entry in
12049 * Glauber data array correspondingly
12050 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12051 IF (IOFFST(IDPROJ).EQ.-1) THEN
12052 STOP ' GLBSET: no data for this projectile !'
12053 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12054 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12059 * get energy bin and interpolation factor
12061 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12068 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12075 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12080 IE0 = (E-ELO)/DEBIN+1
12082 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12084 * get target nucleus index
12088 NBDIFF = ABS(NB-IBBIN(I))
12089 IF (NB.EQ.IBBIN(I)) THEN
12092 ELSEIF (NBDIFF.LE.NBACC) THEN
12097 IF (KB.NE.0) GOTO 21
12098 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12102 * get projectile nucleus bin and interpolation factor
12106 IF (IDXOFF.GT.0) THEN
12111 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12113 IF (NA.EQ.IABIN(I)) THEN
12117 ELSEIF (NA.LT.IABIN(I)) THEN
12123 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12127 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12131 * interpolate profile functions for interactions ka0-kb and ka1-kb
12132 * for energy E separately
12133 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12134 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12135 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12136 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12138 BPRO0(I) = BPROFL(IDX0,I)
12139 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12140 BPRO1(I) = BPROFL(IDY0,I)
12141 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12143 RADB = DT_RNCLUS(NB)
12144 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12145 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12147 * interpolate cross sections for energy E and projectile mass
12149 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12150 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12151 XS(I) = XS0+FACNA*(XS1-XS0)
12152 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12153 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12154 XE(I) = XE0+FACNA*(XE1-XE0)
12157 * interpolate between ka0 and ka1
12158 RADA = DT_RNCLUS(NA)
12159 BMX = 2.0D0*(RADA+RADB)
12160 BSTP = BMX/DBLE(ISITEB-1)
12165 * calculate values of profile functions at B
12167 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12168 IDX1 = MIN(IDX0+1,ISITEB)
12169 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12170 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12172 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12173 IDX1 = MIN(IDX0+1,ISITEB)
12174 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12175 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12177 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12180 * fill common dtglam
12187 BSITE(0,1,1,I) = BPRO(I)
12190 * fill common dtglxs
12191 XSTOT(1,1,1) = XS(1)
12192 XSELA(1,1,1) = XS(2)
12193 XSQEP(1,1,1) = XS(3)
12194 XSQET(1,1,1) = XS(4)
12195 XSQE2(1,1,1) = XS(5)
12196 XSPRO(1,1,1) = XS(6)
12197 XETOT(1,1,1) = XE(1)
12198 XEELA(1,1,1) = XE(2)
12199 XEQEP(1,1,1) = XE(3)
12200 XEQET(1,1,1) = XE(4)
12201 XEQE2(1,1,1) = XE(5)
12202 XEPRO(1,1,1) = XE(6)
12209 *$ CREATE DT_XKSAMP.FOR
12212 *===xksamp=============================================================*
12214 SUBROUTINE DT_XKSAMP(NN,ECM)
12216 ************************************************************************
12217 * Sampling of parton x-values and chain system for one interaction. *
12218 * processed by S. Roesler, 9.8.95 *
12219 ************************************************************************
12221 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12223 PARAMETER ( LINP = 10 ,
12226 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12230 * lower cuts for (valence-sea/sea-valence) chain masses
12231 * antiquark-quark (u/d-sea quark) (s-sea quark)
12232 & AMIU = 0.5D0, AMIS = 0.8D0,
12233 * quark-diquark (u/d-sea quark) (s-sea quark)
12234 & AMAU = 2.6D0, AMAS = 2.6D0,
12235 * maximum lower valence-x threshold
12237 * fraction of sea-diquarks sampled out of sea-partons
12239 C & FRCDIQ = 0.9D0,
12244 * maximum number of trials to generate x's for the required number
12245 * of sea quark pairs for a given hadron
12250 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12252 PARAMETER ( MAXNCL = 260,
12254 & MAXSQU = 20*MAXVQU,
12255 & MAXINT = MAXVQU+MAXSQU)
12257 PARAMETER (NMXHKK=200000)
12258 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12259 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12260 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12261 * particle properties (BAMJET index convention)
12263 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12264 & IICH(210),IIBAR(210),K1(210),K2(210)
12265 * interface between Glauber formalism and DPM
12266 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12267 & INTER1(MAXINT),INTER2(MAXINT)
12268 * properties of interacting particles
12269 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12270 * threshold values for x-sampling (DTUNUC 1.x)
12271 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12273 * x-values of partons (DTUNUC 1.x)
12274 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12275 & XTVQ(MAXVQU),XTVD(MAXVQU),
12276 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12277 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12278 * flavors of partons (DTUNUC 1.x)
12279 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12280 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12281 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12282 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12283 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12284 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12285 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12286 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12287 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12288 & IXPV,IXPS,IXTV,IXTS,
12289 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12290 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12291 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12292 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12293 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12294 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12295 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12296 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12297 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12298 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12299 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12300 * auxiliary common for chain system storage (DTUNUC 1.x)
12301 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12302 * flags for input different options
12303 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12304 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12305 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12306 * various options for treatment of partons (DTUNUC 1.x)
12307 * (chain recombination, Cronin,..)
12308 LOGICAL LCO2CR,LINTPT
12309 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12312 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12315 * (1) initializations
12316 *-----------------------------------------------------------------------
12319 IF (ECM.LT.4.5D0) THEN
12322 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12323 C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12324 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12333 IF (I.LE.MAXVQU) THEN
12339 * lower thresholds for x-selection
12340 * sea-quarks (default: CSEA=0.2)
12341 IF (ECM.LT.10.0D0) THEN
12343 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12344 C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12346 C XSTHR = ONE/ECM**2
12350 XSTHR = CSEA/ECM**2
12351 C XSTHR = ONE/ECM**2
12353 IF ((IP.GE.150).AND.(IT.GE.150))
12354 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12357 * (default: SSMIMA=0.14) used for sea-diquarks (?)
12358 XSSTHR = SSMIMA/ECM
12360 * valence-quarks (default: CVQ=1.0)
12362 * valence-diquarks (default: CDQ=2.0)
12365 * maximum-x for sea-quarks
12366 XVCUT = XVTHR+XDTHR
12367 IF (XVCUT.GT.XVMAX) THEN
12369 XVTHR = XVCUT/3.0D0
12370 XDTHR = XVCUT-XVTHR
12373 **sr 18.4. test: DPMJET
12374 C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12375 C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12376 C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12378 * maximum number of sea-pairs allowed kinematically
12379 C NSMAX = INT(OHALF*XXSEAM/XSTHR)
12380 RNSMAX = OHALF*XXSEAM/XSTHR
12381 IF (RNSMAX.GT.10000.0D0) THEN
12384 NSMAX = INT(OHALF*XXSEAM/XSTHR)
12386 * check kinematical limit for valence-x thresholds
12387 * (should be obsolete now)
12388 IF (XVCUT.GT.XVMAX) THEN
12389 WRITE(LOUT,1000) XVCUT,ECM
12390 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
12391 & ' thresholds not allowed (',2E9.3,')')
12392 C XVTHR = XVMAX-XDTHR
12393 C IF (XVTHR.LT.ZERO) STOP
12397 * set eta for valence-x sampling (BETREJ)
12398 * (UNON per default, UNOM used for projectile mesons only)
12399 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12405 * (2) select parton x-values of interacting projectile nucleons
12406 *-----------------------------------------------------------------------
12412 * get interacting projectile nucleon as sampled by Glauber
12413 IF (JSSH(IPP).NE.0) THEN
12419 * JIPP is the actual number of sea-pairs sampled for this nucleon
12420 JIPP = MIN(JSSH(IPP)-1,NSMAX)
12423 IF (JIPP.GT.0) THEN
12424 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12426 IF (XSTHR.GE.XSMAX) THEN
12431 *>>>get x-values of sea-quark pairs
12435 * accumulator for sea x-values
12438 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12439 IF (NSCOUN.GT.NSEA) THEN
12440 * decrease the number of interactions after NSEA trials
12446 IF (IPSQ(IXPS+1).LE.2) THEN
12447 **sr 8.4.98 (1/sqrt(x))
12448 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12449 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12450 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12453 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12454 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12456 **sr 8.4.98 (1/sqrt(x))
12457 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12458 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12459 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12464 IF (IPSAQ(IXPS+1).GE.-2) THEN
12465 **sr 8.4.98 (1/sqrt(x))
12466 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12467 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12468 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12471 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12472 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12474 **sr 8.4.98 (1/sqrt(x))
12475 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12476 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12477 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12481 XXSEA = XXSEA+XPSQI+XPSAQI
12482 * check for maximum allowed sea x-value
12483 IF (XXSEA.GE.XXSEAM) THEN
12487 * accept this sea-quark pair
12490 XPSAQ(IXPS) = XPSAQI
12492 ZUOSP(IXPS) = .TRUE.
12496 *>>>get x-values of valence partons
12498 IF (XVTHR.GT.0.05D0) THEN
12499 XVHI = ONE-XXSEA-XDTHR
12500 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12503 XPVQI = DT_DBETAR(OHALF,UNOPRV)
12504 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12508 XPVDI = ONE-XPVQI-XXSEA
12509 * reject according to x**1.5
12510 XDTMP = XPVDI**1.5D0
12511 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12512 * accept these valence partons
12518 ZUOVP(IXPV) = .TRUE.
12523 * (3) select parton x-values of interacting target nucleons
12524 *-----------------------------------------------------------------------
12530 * get interacting target nucleon as sampled by Glauber
12531 IF (JTSH(ITT).NE.0) THEN
12537 * JITT is the actual number of sea-pairs sampled for this nucleon
12538 JITT = MIN(JTSH(ITT)-1,NSMAX)
12541 IF (JITT.GT.0) THEN
12542 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12544 IF (XSTHR.GE.XSMAX) THEN
12549 *>>>get x-values of sea-quark pairs
12553 * accumulator for sea x-values
12556 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12557 IF (NSCOUN.GT.NSEA)THEN
12558 * decrease the number of interactions after NSEA trials
12564 IF (ITSQ(IXTS+1).LE.2) THEN
12565 **sr 8.4.98 (1/sqrt(x))
12566 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12567 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12568 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12571 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12572 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12574 **sr 8.4.98 (1/sqrt(x))
12575 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12576 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12577 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12582 IF (ITSAQ(IXTS+1).GE.-2) THEN
12583 **sr 8.4.98 (1/sqrt(x))
12584 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12585 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12586 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12589 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12590 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12592 **sr 8.4.98 (1/sqrt(x))
12593 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12594 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12595 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12599 XXSEA = XXSEA+XTSQI+XTSAQI
12600 * check for maximum allowed sea x-value
12601 IF (XXSEA.GE.XXSEAM) THEN
12605 * accept this sea-quark pair
12608 XTSAQ(IXTS) = XTSAQI
12610 ZUOST(IXTS) = .TRUE.
12614 *>>>get x-values of valence partons
12616 IF (XVTHR.GT.0.05D0) THEN
12617 XVHI = ONE-XXSEA-XDTHR
12618 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12621 XTVQI = DT_DBETAR(OHALF,UNON)
12622 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12626 XTVDI = ONE-XTVQI-XXSEA
12627 * reject according to x**1.5
12628 XDTMP = XTVDI**1.5D0
12629 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12630 * accept these valence partons
12636 ZUOVT(IXTV) = .TRUE.
12641 * (4) get valence-valence chains
12642 *-----------------------------------------------------------------------
12647 IPVAL = ITOVP(INTER1(I))
12648 ITVAL = ITOVT(INTER2(I))
12649 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12651 ZUOVP(IPVAL) = .FALSE.
12652 ZUOVT(ITVAL) = .FALSE.
12655 INTVV1(NVV) = IPVAL
12656 INTVV2(NVV) = ITVAL
12660 * (5) get sea-valence chains
12661 *-----------------------------------------------------------------------
12668 IPVAL = ITOVP(INTER1(I))
12669 ITVAL = ITOVT(INTER2(I))
12671 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12672 & ZUOVT(ITVAL)) THEN
12674 ZUOVT(ITVAL) = .FALSE.
12676 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12677 * sample sea-diquark pair
12678 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12679 IF (IREJ1.EQ.0) GOTO 260
12684 INTSV2(NSV) = ITVAL
12686 *>>>correct chain kinematics according to minimum chain masses
12687 * the actual chain masses
12688 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12689 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12690 * get lower mass cuts
12691 IF (IPSQ(J).EQ.3) THEN
12696 * q being u/d-quark
12701 * chain mass above minimum - resampling of sea-q x-value
12702 IF (AMSVQ1.GT.AMCHK1) THEN
12703 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
12704 **sr 8.4.98 (1/sqrt(x))
12705 C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
12706 C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
12707 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12709 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12711 * chain mass below minimum - reset sea-q x-value and correct
12712 * diquark-x of the same nucleon
12713 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12714 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
12715 DXPSQ = XPSQW-XPSQ(J)
12716 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12717 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12722 * chain mass below minimum - reset sea-aq x-value and correct
12723 * diquark-x of the same nucleon
12724 IF (AMSVQ2.LT.AMCHK2) THEN
12725 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12726 DXPSQ = XPSQW-XPSAQ(J)
12727 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12728 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12732 *>>>end of chain mass correction
12741 * (6) get valence-sea chains
12742 *-----------------------------------------------------------------------
12748 IPVAL = ITOVP(INTER1(I))
12749 ITVAL = ITOVT(INTER2(I))
12751 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12752 & (IFROST(J).EQ.INTER2(I))) THEN
12754 ZUOVP(IPVAL) = .FALSE.
12756 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12757 * sample sea-diquark pair
12758 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12759 IF (IREJ1.EQ.0) GOTO 290
12763 INTVS1(NVS) = IPVAL
12766 *>>>correct chain kinematics according to minimum chain masses
12767 * the actual chain masses
12768 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12769 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12770 * get lower mass cuts
12771 IF (ITSQ(J).EQ.3) THEN
12776 * q being u/d-quark
12781 * chain mass below minimum - reset sea-aq x-value and correct
12782 * diquark-x of the same nucleon
12783 IF (AMVSQ1.LT.AMCHK1) THEN
12784 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12785 DXTSQ = XTSQW-XTSAQ(J)
12786 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12787 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12792 * chain mass above minimum - resampling of sea-q x-value
12793 IF (AMVSQ2.GT.AMCHK2) THEN
12794 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
12795 **sr 8.4.98 (1/sqrt(x))
12796 C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
12797 C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
12798 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12800 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12802 * chain mass below minimum - reset sea-q x-value and correct
12803 * diquark-x of the same nucleon
12804 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12805 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
12806 DXTSQ = XTSQW-XTSQ(J)
12807 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12808 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12812 *>>>end of chain mass correction
12821 * (7) get sea-sea chains
12822 *-----------------------------------------------------------------------
12829 IPVAL = ITOVP(INTER1(I))
12830 ITVAL = ITOVT(INTER2(I))
12831 * loop over target partons not yet matched
12833 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12834 * loop over projectile partons not yet matched
12836 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12837 ZUOSP(JJ) = .FALSE.
12845 *---->chain recombination option
12846 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
12847 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12849 * sea-sea chains may recombine with valence-valence chains
12850 * only if they have the same projectile or target nucleon
12852 IF (ISKPCH(8,IVV).NE.99) THEN
12853 IXVPR = INTVV1(IVV)
12854 IXVTA = INTVV2(IVV)
12855 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12856 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12857 * recombination possible, drop old v-v and s-s chains
12861 * (a) assign new s-v chains
12862 * ~~~~~~~~~~~~~~~~~~~~~~~~~
12864 & (DT_RNDM(VALFRA).GT.FRCDIQ))
12866 * sample sea-diquark pair
12867 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12869 IF (IREJ1.EQ.0) GOTO 4202
12874 INTSV2(NSV) = IXVTA
12875 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12876 * the actual chain masses
12877 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12879 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12881 * get lower mass cuts
12882 IF (IPSQ(JJ).EQ.3) THEN
12887 * q being u/d-quark
12892 * chain mass above minimum - resampling of sea-q x-value
12893 IF (AMSVQ1.GT.AMCHK1) THEN
12895 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12896 **sr 8.4.98 (1/sqrt(x))
12898 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12899 C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
12900 C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
12903 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12905 * chain mass below minimum - reset sea-q x-value and correct
12906 * diquark-x of the same nucleon
12907 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12909 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12910 DXPSQ = XPSQW-XPSQ(JJ)
12911 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12914 & XPVD(IPVAL)-DXPSQ
12919 * chain mass below minimum - reset sea-aq x-value and correct
12920 * diquark-x of the same nucleon
12921 IF (AMSVQ2.LT.AMCHK2) THEN
12923 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
12924 DXPSQ = XPSQW-XPSAQ(JJ)
12925 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12928 & XPVD(IPVAL)-DXPSQ
12932 *>>>>>>>>>>>end of chain mass correction
12935 * (b) assign new v-s chains
12936 * ~~~~~~~~~~~~~~~~~~~~~~~~~
12938 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
12940 * sample sea-diquark pair
12941 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12943 IF (IREJ1.EQ.0) GOTO 4203
12947 INTVS1(NVS) = IXVPR
12949 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12950 * the actual chain masses
12951 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12952 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12953 * get lower mass cuts
12954 IF (ITSQ(J).EQ.3) THEN
12959 * q being u/d-quark
12964 * chain mass below minimum - reset sea-aq x-value and correct
12965 * diquark-x of the same nucleon
12966 IF (AMVSQ1.LT.AMCHK1) THEN
12968 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
12969 DXTSQ = XTSQW-XTSAQ(J)
12970 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12973 & XTVD(ITVAL)-DXTSQ
12977 IF (AMVSQ2.GT.AMCHK2) THEN
12979 & AMCHK2/(XPVD(IXVPR)*ECM**2)
12980 **sr 8.4.98 (1/sqrt(x))
12982 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12983 C & DT_SAMSQX(XTSQTH,XTSQ(J))
12984 C & DT_SAMPEX(XTSQTH,XTSQ(J))
12987 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
12989 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12991 & AMCHK2/(XPVD(IXVPR)*ECM**2)
12992 DXTSQ = XTSQW-XTSQ(J)
12993 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12996 & XTVD(ITVAL)-DXTSQ
13000 *>>>>>>>>>end of chain mass correction
13002 * jump out of s-s chain loop
13008 *---->end of chain recombination option
13010 * sample sea-diquark pair (projectile)
13011 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13012 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13013 IF (IREJ1.EQ.0) THEN
13018 * sample sea-diquark pair (target)
13019 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13020 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13021 IF (IREJ1.EQ.0) THEN
13026 *>>>>>correct chain kinematics according to minimum chain masses
13027 * the actual chain masses
13028 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13029 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13030 * check for lower mass cuts
13031 IF ((SSMA1Q.LT.SSMIMQ).OR.
13032 & (SSMA2Q.LT.SSMIMQ)) THEN
13033 IPVAL = ITOVP(INTER1(I))
13034 ITVAL = ITOVT(INTER2(I))
13035 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13036 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13037 * maximum allowed x values for sea quarks
13038 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13040 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13042 * resampling of x values not possible - skip sea-sea chains
13043 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13044 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13045 * resampling of x for projectile sea quark pair
13049 IF (XSSTHR.GT.0.05D0) THEN
13050 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13052 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13056 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13057 IF ((XPSQI.LT.XSSTHR).OR.
13058 & (XPSQI.GT.XSPMAX)) GOTO 320
13060 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13061 IF ((XPSAQI.LT.XSSTHR).OR.
13062 & (XPSAQI.GT.XSPMAX)) GOTO 330
13064 * final test of remaining x for projectile diquark
13065 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13066 & +XPSQ(JJ)+XPSAQ(JJ)
13067 IF (XPVDCO.LE.XDTHR) THEN
13069 C IF (ICOUS.LT.5) GOTO 310
13070 IF (ICOUS.LT.0.5D0) GOTO 310
13073 * resampling of x for target sea quark pair
13077 IF (XSSTHR.GT.0.05D0) THEN
13078 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13080 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13084 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13085 IF ((XTSQI.LT.XSSTHR).OR.
13086 & (XTSQI.GT.XSTMAX)) GOTO 360
13088 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13089 IF ((XTSAQI.LT.XSSTHR).OR.
13090 & (XTSAQI.GT.XSTMAX)) GOTO 370
13092 * final test of remaining x for target diquark
13093 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13094 & +XTSQ(J)+XTSAQ(J)
13095 IF (XTVDCO.LT.XDTHR) THEN
13096 IF (ICOUS.LT.5) GOTO 350
13099 XPVD(IPVAL) = XPVDCO
13100 XTVD(ITVAL) = XTVDCO
13105 *>>>>>end of chain mass correction
13108 * come here to discard s-s interaction
13109 * resampling of x values not allowed or unsuccessful
13116 * consider next s-s interaction
13126 * correct x-values of valence quarks for non-matching sea quarks
13129 IPVAL = ITOVP(IFROSP(I))
13130 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13138 ITVAL = ITOVT(IFROST(I))
13139 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13146 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13149 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13155 *$ CREATE DT_SAMSDQ.FOR
13158 *===samsdq=============================================================*
13160 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13162 ************************************************************************
13163 * SAMpling of Sea-DiQuarks *
13164 * ECM cm-energy of the nucleon-nucleon system *
13165 * IDX1,2 indices of x-values of the participating *
13166 * partons (IDX2 is always the sea-q-pair to be *
13167 * changed to sea-qq-pair) *
13168 * MODE = 1 valence-q - sea-diq *
13169 * = 2 sea-diq - valence-q *
13170 * = 3 sea-q - sea-diq *
13171 * = 4 sea-diq - sea-q *
13172 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13173 * This version dated 17.10.95 is written by S. Roesler *
13174 ************************************************************************
13176 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13179 PARAMETER (ZERO=0.0D0)
13181 * threshold values for x-sampling (DTUNUC 1.x)
13182 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13184 * various options for treatment of partons (DTUNUC 1.x)
13185 * (chain recombination, Cronin,..)
13186 LOGICAL LCO2CR,LINTPT
13187 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13189 PARAMETER ( MAXNCL = 260,
13191 & MAXSQU = 20*MAXVQU,
13192 & MAXINT = MAXVQU+MAXSQU)
13193 * x-values of partons (DTUNUC 1.x)
13194 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13195 & XTVQ(MAXVQU),XTVD(MAXVQU),
13196 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13197 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13198 * flavors of partons (DTUNUC 1.x)
13199 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13200 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13201 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13202 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13203 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13204 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13205 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13206 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13207 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13208 & IXPV,IXPS,IXTV,IXTS,
13209 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13210 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13211 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13212 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13213 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13214 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13215 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13216 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13217 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13218 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13219 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13220 * auxiliary common for chain system storage (DTUNUC 1.x)
13221 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13224 * threshold-x for valence diquarks
13227 GOTO (1,2,3,4) MODE
13229 *---------------------------------------------------------------------
13230 * proj. valence partons - targ. sea partons
13231 * get x-values and flavors for target sea-diquark pair
13237 * index of corr. val-diquark-x in target nucleon
13238 IDXVT = ITOVT(IFROST(IDXST))
13239 * available x above diquark thresholds for valence- and sea-diquarks
13240 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13242 IF (XXD.GE.ZERO) THEN
13243 * x-values for the three diquarks of the target nucleon
13247 SR123 = RR1+RR2+RR3
13248 XXTV = XDTHR+RR1*XXD/SR123
13249 XXTSQ = XDTHR+RR2*XXD/SR123
13250 XXTSAQ = XDTHR+RR3*XXD/SR123
13253 XXTSQ = XTSQ(IDXST)
13254 XXTSAQ = XTSAQ(IDXST)
13256 * flavor of the second quarks in the sea-diquark pair
13257 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13258 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13259 * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13260 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13261 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13262 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13264 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13267 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13268 * at least one strange quark
13269 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13272 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13276 * accept the new sea-diquark
13278 XTSQ(IDXST) = XXTSQ
13279 XTSAQ(IDXST) = XXTSAQ
13281 INTVD1(NVD) = IDXVP
13282 INTVD2(NVD) = IDXST
13286 *---------------------------------------------------------------------
13287 * proj. sea partons - targ. valence partons
13288 * get x-values and flavors for projectile sea-diquark pair
13294 * index of corr. val-diquark-x in projectile nucleon
13295 IDXVP = ITOVP(IFROSP(IDXSP))
13296 * available x above diquark thresholds for valence- and sea-diquarks
13297 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13299 IF (XXD.GE.ZERO) THEN
13300 * x-values for the three diquarks of the projectile nucleon
13304 SR123 = RR1+RR2+RR3
13305 XXPV = XDTHR+RR1*XXD/SR123
13306 XXPSQ = XDTHR+RR2*XXD/SR123
13307 XXPSAQ = XDTHR+RR3*XXD/SR123
13310 XXPSQ = XPSQ(IDXSP)
13311 XXPSAQ = XPSAQ(IDXSP)
13313 * flavor of the second quarks in the sea-diquark pair
13314 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13315 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13316 * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13317 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13318 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13319 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13321 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13324 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13325 * at least one strange quark
13326 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13329 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13333 * accept the new sea-diquark
13335 XPSQ(IDXSP) = XXPSQ
13336 XPSAQ(IDXSP) = XXPSAQ
13338 INTDV1(NDV) = IDXSP
13339 INTDV2(NDV) = IDXVT
13343 *---------------------------------------------------------------------
13344 * proj. sea partons - targ. sea partons
13345 * get x-values and flavors for target sea-diquark pair
13351 * index of corr. val-diquark-x in target nucleon
13352 IDXVT = ITOVT(IFROST(IDXST))
13353 * available x above diquark thresholds for valence- and sea-diquarks
13354 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13356 IF (XXD.GE.ZERO) THEN
13357 * x-values for the three diquarks of the target nucleon
13361 SR123 = RR1+RR2+RR3
13362 XXTV = XDTHR+RR1*XXD/SR123
13363 XXTSQ = XDTHR+RR2*XXD/SR123
13364 XXTSAQ = XDTHR+RR3*XXD/SR123
13367 XXTSQ = XTSQ(IDXST)
13368 XXTSAQ = XTSAQ(IDXST)
13370 * flavor of the second quarks in the sea-diquark pair
13371 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13372 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13373 * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13374 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
13375 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13376 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13378 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13381 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13382 * at least one strange quark
13383 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13386 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13390 * accept the new sea-diquark
13392 XTSQ(IDXST) = XXTSQ
13393 XTSAQ(IDXST) = XXTSAQ
13395 INTSD1(NSD) = IDXSP
13396 INTSD2(NSD) = IDXST
13400 *---------------------------------------------------------------------
13401 * proj. sea partons - targ. sea partons
13402 * get x-values and flavors for projectile sea-diquark pair
13408 * index of corr. val-diquark-x in projectile nucleon
13409 IDXVP = ITOVP(IFROSP(IDXSP))
13410 * available x above diquark thresholds for valence- and sea-diquarks
13411 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13413 IF (XXD.GE.ZERO) THEN
13414 * x-values for the three diquarks of the projectile nucleon
13418 SR123 = RR1+RR2+RR3
13419 XXPV = XDTHR+RR1*XXD/SR123
13420 XXPSQ = XDTHR+RR2*XXD/SR123
13421 XXPSAQ = XDTHR+RR3*XXD/SR123
13424 XXPSQ = XPSQ(IDXSP)
13425 XXPSAQ = XPSAQ(IDXSP)
13427 * flavor of the second quarks in the sea-diquark pair
13428 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13429 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13430 * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13431 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
13432 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
13433 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13435 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13438 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13439 * at least one strange quark
13440 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13443 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13447 * accept the new sea-diquark
13449 XPSQ(IDXSP) = XXPSQ
13450 XPSAQ(IDXSP) = XXPSAQ
13452 INTDS1(NDS) = IDXSP
13453 INTDS2(NDS) = IDXST
13458 *$ CREATE DT_DIFEVT.FOR
13461 *===difevt=============================================================*
13463 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13464 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13466 ************************************************************************
13467 * Interface to treatment of diffractive interactions. *
13468 * (input) IFP1/2 PDG-indizes of projectile partons *
13469 * (baryon: IFP2 - adiquark) *
13470 * PP(4) projectile 4-momentum *
13471 * IFT1/2 PDG-indizes of target partons *
13472 * (baryon: IFT1 - adiquark) *
13473 * PT(4) target 4-momentum *
13474 * (output) JDIFF = 0 no diffraction *
13475 * = 1/-1 LMSD/LMDD *
13476 * = 2/-2 HMSD/HMDD *
13477 * NCSY counter for two-chain systems *
13478 * dumped to DTEVT1 *
13479 * This version dated 14.02.95 is written by S. Roesler *
13480 ************************************************************************
13482 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13484 PARAMETER ( LINP = 10 ,
13487 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13491 PARAMETER (NMXHKK=200000)
13492 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13493 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13494 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13495 * extended event history
13496 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13497 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13499 * flags for diffractive interactions (DTUNUC 1.x)
13500 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13502 DIMENSION PP(4),PT(4)
13505 DATA LFIRST /.TRUE./
13512 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13513 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13514 * identities of projectile hadron / target nucleon
13515 KPROJ = IDT_ICIHAD(IDHKK(MOP))
13516 KTARG = IDT_ICIHAD(IDHKK(MOT))
13518 * single diffractive xsections
13519 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13520 * double diffractive xsections
13521 **!! no double diff yet
13522 C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13526 * total inelastic xsection
13527 C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13529 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13530 SIGIN = MAX(SIGTO-SIGEL,ZERO)
13532 * fraction of diffractive processes
13533 FRADIF = (SDTOT+DDTOT)/SIGIN
13536 WRITE(LOUT,1000) XM,SDTOT,SIGIN
13537 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13538 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13543 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13544 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13545 * diffractive interaction requested by x-section or by user
13546 FRASD = SDTOT/(SDTOT+DDTOT)
13547 FRASDH = SDHM/SDTOT
13548 **sr needs to be specified!!
13549 C FRADDH = DDHM/DDTOT
13552 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13553 * single diffraction
13555 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13558 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13559 & ISINGD.NE.3) THEN
13566 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13567 & ISINGD.NE.3) THEN
13573 * double diffraction
13575 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13583 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13584 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13585 IF (IREJ1.EQ.0) THEN
13587 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13601 *$ CREATE DT_DIFFKI.FOR
13604 *===difkin=============================================================*
13606 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13607 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13609 ************************************************************************
13610 * Kinematics of diffractive nucleon-nucleon interaction. *
13611 * IFP1/2 PDG-indizes of projectile partons *
13612 * (baryon: IFP2 - adiquark) *
13613 * PP(4) projectile 4-momentum *
13614 * IFT1/2 PDG-indizes of target partons *
13615 * (baryon: IFT1 - adiquark) *
13616 * PT(4) target 4-momentum *
13617 * KP = 0 projectile quasi-elastically scattered *
13618 * = 1 excited to low-mass diff. state *
13619 * = 2 excited to high-mass diff. state *
13620 * KT = 0 target quasi-elastically scattered *
13621 * = 1 excited to low-mass diff. state *
13622 * = 2 excited to high-mass diff. state *
13623 * This version dated 12.02.95 is written by S. Roesler *
13624 ************************************************************************
13626 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13628 PARAMETER ( LINP = 10 ,
13631 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13635 * particle properties (BAMJET index convention)
13637 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13638 & IICH(210),IIBAR(210),K1(210),K2(210)
13639 * flags for input different options
13640 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13641 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13642 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13643 * rejection counter
13644 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13645 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13646 & IREXCI(3),IRDIFF(2),IRINC
13647 * kinematics of diffractive interactions (DTUNUC 1.x)
13648 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13650 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13651 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13653 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13654 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13656 DATA LSTART /.TRUE./
13660 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
13666 * initialize common /DTDIKI/
13668 * store momenta of initial incoming particles for emc-check
13670 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13671 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13674 * masses of initial particles
13675 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13676 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13677 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13680 * check quark-input (used to adjust coherence cond. for M-selection)
13682 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13684 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13686 * parameter for Lorentz-transformation into nucleon-nucleon cms
13688 PITOT(K) = PP(K)+PT(K)
13690 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13691 IF (XMTOT2.LE.ZERO) THEN
13692 WRITE(LOUT,1000) XMTOT2
13693 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
13694 & 'XMTOT2 = ',E12.3)
13697 XMTOT = SQRT(XMTOT2)
13699 BGTOT(K) = PITOT(K)/XMTOT
13701 * transformation of nucleons into cms
13702 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13703 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13704 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13705 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13708 C SID = SQRT((ONE-COD)*(ONE+COD))
13709 PPT = SQRT(PP1(1)**2+PP1(2)**2)
13713 IF(PPTOT*SID.GT.TINY10) THEN
13714 COF = PP1(1)/(SID*PPTOT)
13715 SIF = PP1(2)/(SID*PPTOT)
13716 ANORF = SQRT(COF*COF+SIF*SIF)
13720 * check consistency
13722 DEV1(K) = ABS(PP1(K)+PT1(K))
13724 DEV1(4) = ABS(DEV1(4)-XMTOT)
13725 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13726 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
13727 WRITE(LOUT,1001) DEV1
13728 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
13733 * select x-fractions in high-mass diff. interactions
13734 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13736 * select diffractive masses
13739 XMPF = DT_XMLMD(XMTOT)
13740 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13741 IF (IREJ1.GT.0) GOTO 9999
13742 ELSEIF (KP.EQ.2) THEN
13743 XMPF = DT_XMHMD(XMTOT,IBP,1)
13749 XMTF = DT_XMLMD(XMTOT)
13750 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13751 IF (IREJ1.GT.0) GOTO 9999
13752 ELSEIF (KT.EQ.2) THEN
13753 XMTF = DT_XMHMD(XMTOT,IBT,2)
13758 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13761 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13762 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13764 * select momentum transfer (all t-values used here are <0)
13765 * minimum absolute value to produce diffractive masses
13766 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13767 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13768 IF (IREJ1.GT.0) GOTO 9999
13770 * longitudinal momentum of excited/elastically scattered projectile
13771 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13772 * total transverse momentum due to t-selection
13773 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13774 IF (PPBLT2.LT.ZERO) THEN
13775 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13776 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
13777 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13780 CALL DT_DSFECF(SINPHI,COSPHI)
13781 PPBLT = SQRT(PPBLT2)
13782 PPBLOB(1) = COSPHI*PPBLT
13783 PPBLOB(2) = SINPHI*PPBLT
13785 * rotate excited/elastically scattered projectile into n-n cms.
13786 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13792 * 4-momentum of excited/elastically scattered target and of exchanged
13795 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13796 PPOM1(K) = PP1(K)-PPBLOB(K)
13798 PTBLOB(4) = XMTOT-PPBLOB(4)
13800 * Lorentz-transformation back into system of initial diff. collision
13801 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13802 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13803 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13804 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13805 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13806 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13807 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13808 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13809 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13811 * store 4-momentum of elastically scattered particle (in single diff.
13817 ELSEIF (KT.EQ.0) THEN
13823 * check consistency of kinematical treatment so far
13825 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13826 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13827 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13828 IF (IREJ1.NE.0) GOTO 9999
13831 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13832 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13834 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13835 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13836 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13837 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
13838 WRITE(LOUT,1003) DEV1,DEV2
13839 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
13844 * kinematical treatment for low-mass diffraction
13845 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13846 IF (IREJ1.NE.0) GOTO 9999
13848 * dump diffractive chains into DTEVT1
13849 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13850 IF (IREJ1.NE.0) GOTO 9999
13855 IRDIFF(1) = IRDIFF(1)+1
13860 *$ CREATE DT_XMHMD.FOR
13863 *===xmhmd==============================================================*
13865 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13867 ************************************************************************
13868 * Diffractive mass in high mass single/double diffractive events. *
13869 * This version dated 11.02.95 is written by S. Roesler *
13870 ************************************************************************
13872 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13874 PARAMETER ( LINP = 10 ,
13877 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13879 * kinematics of diffractive interactions (DTUNUC 1.x)
13880 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13882 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13883 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13885 C DATA XCOLOW /0.05D0/
13886 DATA XCOLOW /0.15D0/
13890 IF (MODE.EQ.2) XH = XTH(2)
13892 * minimum Pomeron-x for high-mass diffraction
13893 * (adjusted to get a smooth transition between HM and LM component)
13895 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13896 IF (ECM.LE.300.0D0) THEN
13897 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13898 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13900 * maximum Pomeron-x for high-mass diffraction
13901 * (coherence condition, adjusted to fit to experimental data)
13903 * baryon-diffraction
13904 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13906 * meson-diffraction
13907 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13910 IF (XDIMIN.GE.XDIMAX) THEN
13911 XDIMIN = OHALF*XDIMAX
13917 IF (KLOOP.GT.20) RETURN
13918 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
13919 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13920 * corr. diffr. mass
13921 DT_XMHMD = ECM*SQRT(XDIFF)
13922 IF (DT_XMHMD.LT.2.5D0) GOTO 1
13927 *$ CREATE DT_XMLMD.FOR
13930 *===xmlmd==============================================================*
13932 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13934 ************************************************************************
13935 * Diffractive mass in high mass single/double diffractive events. *
13936 * This version dated 11.02.95 is written by S. Roesler *
13937 ************************************************************************
13939 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13941 PARAMETER ( LINP = 10 ,
13945 * minimum Pomeron-x for low-mass diffraction
13948 * maximum Pomeron-x for low-mass diffraction
13949 * (adjusted to get a smooth transition between HM and LM component)
13952 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13953 R = DT_RNDM(AMO)*SAM
13954 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13955 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13957 * selection of diffractive mass
13958 * (adjusted to get a smooth transition between HM and LM component)
13960 IF (ECM.LE.50.0D0) THEN
13961 DT_XMLMD = AMO*(AMU/AMO)**R
13964 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
13965 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
13971 *$ CREATE DT_TDIFF.FOR
13974 *===tdiff==============================================================*
13976 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
13978 ************************************************************************
13979 * t-selection for single/double diffractive interactions. *
13981 * TMIN minimum momentum transfer to produce diff. masses *
13982 * XM1/XM2 diffractively produced masses *
13983 * (for single diffraction XM2 is obsolete) *
13984 * K1/K2= 0 not excited *
13985 * = 1 low-mass excitation *
13986 * = 2 high-mass excitation *
13987 * This version dated 11.02.95 is written by S. Roesler *
13988 ************************************************************************
13990 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13992 PARAMETER ( LINP = 10 ,
13995 PARAMETER (ZERO=0.0D0)
13997 PARAMETER ( BTP0 = 3.7D0,
13998 & ALPHAP = 0.24D0 )
14011 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14012 * slope for single diffraction
14013 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14015 * slope for double diffraction
14016 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14021 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14023 T = -LOG(1.0D0-Y)/SLOPE
14024 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14030 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14031 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14032 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14033 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14038 *$ CREATE DT_XVALHM.FOR
14041 *===xvalhm=============================================================*
14043 SUBROUTINE DT_XVALHM(KP,KT)
14045 ************************************************************************
14046 * Sampling of parton x-values in high-mass diffractive interactions. *
14047 * This version dated 12.02.95 is written by S. Roesler *
14048 ************************************************************************
14050 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14052 PARAMETER ( LINP = 10 ,
14055 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14057 * kinematics of diffractive interactions (DTUNUC 1.x)
14058 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14060 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14061 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14062 * various options for treatment of partons (DTUNUC 1.x)
14063 * (chain recombination, Cronin,..)
14064 LOGICAL LCO2CR,LINTPT
14065 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14068 DATA UNON,XVQTHR /2.0D0,0.8D0/
14071 * x-fractions of projectile valence partons
14073 XPH(1) = DT_DBETAR(OHALF,UNON)
14074 IF (XPH(1).GE.XVQTHR) GOTO 1
14075 XPH(2) = ONE-XPH(1)
14076 * x-fractions of Pomeron q-aq-pair
14079 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14080 XPPO(2) = ONE-XPPO(1)
14081 * flavors of Pomeron q-aq-pair
14082 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14085 IF (DT_RNDM(UNON).GT.OHALF) THEN
14092 * x-fractions of projectile target partons
14094 XTH(1) = DT_DBETAR(OHALF,UNON)
14095 IF (XTH(1).GE.XVQTHR) GOTO 2
14096 XTH(2) = ONE-XTH(1)
14097 * x-fractions of Pomeron q-aq-pair
14100 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14101 XTPO(2) = ONE-XTPO(1)
14102 * flavors of Pomeron q-aq-pair
14103 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14106 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14115 *$ CREATE DT_LM2RES.FOR
14118 *===lm2res=============================================================*
14120 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14122 ************************************************************************
14123 * Check low-mass diffractive excitation for resonance mass. *
14124 * (input) IF1/2 PDG-indizes of valence partons *
14125 * (in/out) XM diffractive mass requested/corrected *
14126 * (output) IDR/IDXR id./BAMJET-index of resonance *
14127 * This version dated 12.02.95 is written by S. Roesler *
14128 ************************************************************************
14130 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14132 PARAMETER ( LINP = 10 ,
14135 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14137 * kinematics of diffractive interactions (DTUNUC 1.x)
14138 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14140 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14141 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14148 * BAMJET indices of partons
14149 IF1A = IDT_IPDG2B(IF1,1,2)
14150 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14151 IF2A = IDT_IPDG2B(IF2,1,2)
14152 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14154 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14156 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14158 * check for resonance mass
14159 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14160 IF (IREJ1.NE.0) GOTO 9999
14170 *$ CREATE DT_LMKINE.FOR
14173 *===lmkine=============================================================*
14175 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14177 ************************************************************************
14178 * Kinematical treatment of low-mass excitations. *
14179 * This version dated 12.02.95 is written by S. Roesler *
14180 ************************************************************************
14182 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14184 PARAMETER ( LINP = 10 ,
14187 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14189 * flags for input different options
14190 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14191 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14192 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14193 * kinematics of diffractive interactions (DTUNUC 1.x)
14194 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14196 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14197 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14199 DIMENSION P1(4),P2(4)
14204 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14206 FAC1 = OHALF*(POE+ONE)
14207 FAC2 = -OHALF*(POE-ONE)
14209 PPLM1(K) = FAC1*PPF(K)
14210 PPLM2(K) = FAC2*PPF(K)
14212 PPLM1(4) = FAC1*PABS
14213 PPLM2(4) = -FAC2*PABS
14214 IF (IMSHL.EQ.1) THEN
14217 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14218 IF (IREJ1.NE.0) GOTO 9999
14227 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14229 FAC1 = OHALF*(POE+ONE)
14230 FAC2 = -OHALF*(POE-ONE)
14232 PTLM2(K) = FAC1*PTF(K)
14233 PTLM1(K) = FAC2*PTF(K)
14235 PTLM2(4) = FAC1*PABS
14236 PTLM1(4) = -FAC2*PABS
14237 IF (IMSHL.EQ.1) THEN
14240 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14241 IF (IREJ1.NE.0) GOTO 9999
14252 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14257 *$ CREATE DT_DIFINI.FOR
14260 *===difini=============================================================*
14262 SUBROUTINE DT_DIFINI
14264 ************************************************************************
14265 * Initialization of common /DTDIKI/ *
14266 * This version dated 12.02.95 is written by S. Roesler *
14267 ************************************************************************
14269 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14271 PARAMETER ( LINP = 10 ,
14274 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14276 * kinematics of diffractive interactions (DTUNUC 1.x)
14277 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14279 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14280 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14308 *$ CREATE DT_DIFPUT.FOR
14311 *===difput=============================================================*
14313 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14316 ************************************************************************
14317 * Dump diffractive chains into DTEVT1 *
14318 * This version dated 12.02.95 is written by S. Roesler *
14319 ************************************************************************
14321 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14323 PARAMETER ( LINP = 10 ,
14326 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14330 * kinematics of diffractive interactions (DTUNUC 1.x)
14331 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14333 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14334 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14336 PARAMETER (NMXHKK=200000)
14337 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14338 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14339 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14340 * extended event history
14341 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14342 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14344 * rejection counter
14345 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14346 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14347 & IREXCI(3),IRDIFF(2),IRINC
14349 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14350 & P1(4),P2(4),P3(4),P4(4)
14356 PCH(K) = PPLM1(K)+PPLM2(K)
14360 IF (DT_RNDM(PT).GT.OHALF) THEN
14364 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14366 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14368 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14370 ELSEIF (KP.EQ.2) THEN
14372 PP1(K) = XPH(1)*PP(K)
14373 PP2(K) = XPH(2)*PP(K)
14374 PT1(K) = -XPPO(1)*PPOM(K)
14375 PT2(K) = -XPPO(2)*PPOM(K)
14377 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14381 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14382 IF (IREJ1.NE.0) GOTO 9999
14383 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14384 IF (IREJ1.NE.0) GOTO 9999
14391 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14393 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14395 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14397 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14400 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14401 IF (IREJ1.NE.0) GOTO 9999
14402 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14403 IF (IREJ1.NE.0) GOTO 9999
14410 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14412 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14414 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14416 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14421 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14427 PCH(K) = PTLM1(K)+PTLM2(K)
14431 IF (DT_RNDM(PT).GT.OHALF) THEN
14435 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14437 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14439 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14441 ELSEIF (KT.EQ.2) THEN
14443 PP1(K) = XTPO(1)*PPOM(K)
14444 PP2(K) = XTPO(2)*PPOM(K)
14445 PT1(K) = XTH(2)*PT(K)
14446 PT2(K) = XTH(1)*PT(K)
14448 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14452 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14453 IF (IREJ1.NE.0) GOTO 9999
14454 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14455 IF (IREJ1.NE.0) GOTO 9999
14462 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14464 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14466 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14468 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14471 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14472 IF (IREJ1.NE.0) GOTO 9999
14473 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14474 IF (IREJ1.NE.0) GOTO 9999
14481 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14483 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14485 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14487 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14492 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14499 IRDIFF(2) = IRDIFF(2)+1
14504 *$ CREATE DT_EVTFRG.FOR
14507 *===evtfrg=============================================================*
14509 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14511 ************************************************************************
14512 * Hadronization of chains in DTEVT1. *
14515 * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
14516 * = 2 hadronization of DTUNUC-chains (id=88xxx) *
14517 * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
14518 * hadronized with one PYEXEC call *
14519 * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14520 * with one PYEXEC call *
14522 * NPYMEM number of entries in JETSET-common after hadronization *
14523 * IREJ rejection flag *
14525 * This version dated 17.09.00 is written by S. Roesler *
14526 ************************************************************************
14528 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14530 PARAMETER ( LINP = 10 ,
14533 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14534 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14538 PARAMETER (MXJOIN=200)
14541 PARAMETER (NMXHKK=200000)
14542 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14543 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14544 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14545 * extended event history
14546 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14547 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14549 * flags for input different options
14550 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14551 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14552 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14554 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14555 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14557 * flags for diffractive interactions (DTUNUC 1.x)
14558 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14559 * nucleon-nucleon event-generator
14562 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14564 C model switches and parameters
14566 INTEGER ISWMDL,IPAMDL
14567 DOUBLE PRECISION PARMDL
14568 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14571 PARAMETER (MAXLND=4000)
14572 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14574 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14578 IF (MODE.NE.1) ISTSTG = 8
14587 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14588 DO 10 I=NPOINT(3),NEND
14589 * sr 14.02.00: seems to be not necessary anymore, commented
14590 C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14591 C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14593 * pick up chains from dtevt1
14594 IDCHK = IDHKK(I)/10000
14595 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14596 IF (IDCHK.EQ.7) THEN
14597 IPJE = IDHKK(I)-IDCHK*10000
14598 IF (IPJE.NE.IFRG) THEN
14600 IF (IFRG.GT.NFRG) GOTO 16
14605 IF (IFRG.GT.NFRG) THEN
14610 * statistics counter
14611 c IF (IDCH(I).LE.8)
14612 c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14613 c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14614 * special treatment for small chains already corrected to hadrons
14615 IF (IDRES(I).NE.0) THEN
14616 IF (IDRES(I).EQ.11) THEN
14619 ID = IDT_IPDGHA(IDXRES(I))
14622 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14623 & PHKK(4,I),INIEMC,IDUM,IDUM)
14627 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14628 P(IP,1) = PHKK(1,I)
14629 P(IP,2) = PHKK(2,I)
14630 P(IP,3) = PHKK(3,I)
14631 P(IP,4) = PHKK(4,I)
14632 P(IP,5) = PHKK(5,I)
14638 IHIST(2,I) = 10000*IPJE+IP
14639 IF (IHIST(1,I).LE.-100) THEN
14641 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14648 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14650 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14651 & PHKK(4,KK),INIEMC,IDUM,IDUM)
14652 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14656 IF (ID.EQ.0) ID = 21
14657 c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14658 c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14659 c AMRQ = PYMASS(ID)
14660 c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14661 c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14662 c & (ABS(IDIFF).EQ.0)) THEN
14663 cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14664 c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14665 c PHKK(4,KK) = PHKK(4,KK)+DELTA
14666 c PTOT1 = PTOT-DELTA
14667 c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14668 c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14669 c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14670 c PHKK(5,KK) = AMRQ
14673 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14674 P(IP,1) = PHKK(1,KK)
14675 P(IP,2) = PHKK(2,KK)
14676 P(IP,3) = PHKK(3,KK)
14677 P(IP,4) = PHKK(4,KK)
14678 P(IP,5) = PHKK(5,KK)
14684 IHIST(2,KK) = 10000*IPJE+IP
14685 IF (IHIST(1,KK).LE.-100) THEN
14687 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14691 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14696 * join the two-parton system
14697 CALL PYJOIN(IJ,IJOIN)
14707 * final state parton shower
14709 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14710 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14712 IF (ISJOIN(K1).EQ.0) GOTO 130
14714 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14716 IH1 = IHIST(2,I)/10000
14717 IF (IH1.NE.NPJE) GOTO 130
14718 IH1 = IHIST(2,I)-IH1*10000
14720 IF (ISJOIN(K2).EQ.0) GOTO 135
14722 IH2 = IHIST(2,II)/10000
14723 IF (IH2.NE.NPJE) GOTO 135
14724 IH2 = IHIST(2,II)-IH2*10000
14725 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14726 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14727 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14728 RQLUN = MIN(PT1,PT2)
14729 CALL PYSHOW(IH1,IH2,RQLUN)
14741 CALL DT_INITJS(MODE)
14746 IF (MSTU(24).NE.0) THEN
14747 WRITE(LOUT,*) ' JETSET-reject at event',
14748 & NEVHKK,MSTU(24),KMODE
14749 C CALL DT_EVTOUT(4)
14756 * number of entries in LUJETS
14768 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14770 * pick up mother resonance if possible and put it together with
14771 * their decay-products into the common
14773 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14774 KFMOR = K(IDXMOR,2)
14775 ISMOR = K(IDXMOR,1)
14780 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14781 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14783 MO = IHISMO(PYK(IDXMOR,15))
14788 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14791 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14792 IF (PYK(JDAUG,7).EQ.1) THEN
14798 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14804 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14810 * there was no mother resonance
14811 MO = IHISMO(PYK(II,15))
14817 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14823 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14830 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14831 C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14834 * global energy-momentum & flavor conservation check
14835 **sr 16.5. this check is skipped in case of phojet-treatment
14837 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14839 * update statistics-counter for diffraction
14840 c IF (IFLAGD.NE.0) THEN
14841 c ICDIFF(1) = ICDIFF(1)+1
14842 c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14843 c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14844 c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14845 c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14857 *$ CREATE DT_DECAYS.FOR
14860 *===decay==============================================================*
14862 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14864 ************************************************************************
14865 * Resonance-decay. *
14866 * This subroutine replaces DDECAY/DECHKK. *
14867 * PIN(4) 4-momentum of resonance (input) *
14868 * IDXIN BAMJET-index of resonance (input) *
14869 * POUT(20,4) 4-momenta of decay-products (output) *
14870 * IDXOUT(20) BAMJET-indices of decay-products (output) *
14871 * NSEC number of secondaries (output) *
14872 * Adopted from the original version DECHKK. *
14873 * This version dated 09.01.95 is written by S. Roesler *
14874 ************************************************************************
14876 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14878 PARAMETER ( LINP = 10 ,
14881 PARAMETER (TINY17=1.0D-17)
14883 * HADRIN: decay channel information
14884 PARAMETER (IDMAX9=602)
14886 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14887 * particle properties (BAMJET index convention)
14889 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14890 & IICH(210),IIBAR(210),K1(210),K2(210)
14891 * flags for input different options
14892 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14893 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14894 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14896 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14897 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14898 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14900 * ISTAB = 1 strong and weak decays
14901 * = 2 strong decays only
14902 * = 3 strong decays, weak decays for charmed particles and tau
14908 * put initial resonance to stack
14910 IDXSTK(NSTK) = IDXIN
14912 PI(NSTK,I) = PIN(I)
14915 * store initial configuration for energy-momentum cons. check
14916 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14917 & PI(NSTK,4),1,IDUM,IDUM)
14920 * get particle from stack
14921 IDXI = IDXSTK(NSTK)
14922 * skip stable particles
14923 IF (ISTAB.EQ.1) THEN
14924 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14925 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
14926 ELSEIF (ISTAB.EQ.2) THEN
14927 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
14928 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14929 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14930 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14931 IF ( IDXI.EQ.109) GOTO 10
14932 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14933 ELSEIF (ISTAB.EQ.3) THEN
14934 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
14935 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14936 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14937 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14940 * calculate direction cosines and Lorentz-parameter of decaying part.
14941 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14942 PTOT = MAX(PTOT,TINY17)
14944 DCOS(I) = PI(NSTK,I)/PTOT
14946 GAM = PI(NSTK,4)/AAM(IDXI)
14947 BGAM = PTOT/AAM(IDXI)
14949 * get decay-channel
14953 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14955 * identities of secondaries
14956 IDX(1) = NZK(KCHAN,1)
14957 IDX(2) = NZK(KCHAN,2)
14958 IF (IDX(2).LT.1) GOTO 9999
14959 IDX(3) = NZK(KCHAN,3)
14961 * handle decay in rest system of decaying particle
14962 IF (IDX(3).EQ.0) THEN
14963 * two-particle decay
14965 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
14966 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14967 & AAM(IDX(1)),AAM(IDX(2)))
14969 * three-particle decay
14971 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
14972 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14973 & CODF(3),COFF(3),SIFF(3),
14974 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
14978 * transform decay products back
14981 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
14982 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
14983 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
14984 * add particle to stack
14985 IDXSTK(NSTK) = IDX(I)
14987 PI(NSTK,J) = DCOSF(J)*PFF(I)
14993 * stable particle, put to output-arrays
14996 POUT(NSEC,I) = PI(NSTK,I)
14998 IDXOUT(NSEC) = IDXSTK(NSTK)
14999 * store secondaries for energy-momentum conservation check
15001 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15002 & -POUT(NSEC,4),2,IDUM,IDUM)
15004 IF (NSTK.GT.0) GOTO 100
15006 * check energy-momentum conservation
15008 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15009 IF (IREJ1.NE.0) GOTO 9999
15019 *$ CREATE DT_DECAY1.FOR
15022 *===decay1=============================================================*
15024 SUBROUTINE DT_DECAY1
15026 ************************************************************************
15027 * Decay of resonances stored in DTEVT1. *
15028 * This version dated 20.01.95 is written by S. Roesler *
15029 ************************************************************************
15031 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15033 PARAMETER ( LINP = 10 ,
15038 PARAMETER (NMXHKK=200000)
15039 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15040 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15041 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15042 * extended event history
15043 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15044 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15047 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15050 C DO 1 I=NPOINT(5),NEND
15051 DO 1 I=NPOINT(4),NEND
15052 IF (ABS(ISTHKK(I)).EQ.1) THEN
15057 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15058 IF (NSEC.GT.1) THEN
15060 IDHAD = IDT_IPDGHA(IDXOUT(N))
15061 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15062 & POUT(N,3),POUT(N,4),0,0,0)
15071 *$ CREATE DT_DECPI0.FOR
15074 *===decpi0=============================================================*
15076 SUBROUTINE DT_DECPI0
15078 ************************************************************************
15079 * Decay of pi0 handled with JETSET. *
15080 * This version dated 18.02.96 is written by S. Roesler *
15081 ************************************************************************
15083 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15085 PARAMETER ( LINP = 10 ,
15088 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15091 PARAMETER (NMXHKK=200000)
15092 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15093 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15094 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15095 * extended event history
15096 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15097 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15099 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15100 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15101 PARAMETER (MAXLND=4000)
15102 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15103 * flags for input different options
15104 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15105 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15106 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15110 DIMENSION IHISMO(NMXHKK),P1(4)
15112 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15122 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15128 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15129 & PHKK(4,I),INI,IDUM,IDUM)
15130 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15131 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15132 COSTH = PHKK(3,I)/(PTOT+TINY10)
15133 IF (COSTH.GT.ONE) THEN
15135 ELSEIF (COSTH.LT.-ONE) THEN
15136 THETA = TWOPI/2.0D0
15138 THETA = ACOS(COSTH)
15140 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15141 IF (PHKK(1,I).LT.0.0D0)
15142 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15147 P(NN,5) = PHKK(5,I)
15148 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15157 IF (PYK(II,7).EQ.1) THEN
15159 P1(KK) = PYP(II,KK)
15162 MO = IHISMO(PYK(II,15))
15163 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15165 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15167 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15171 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15178 *$ CREATE DT_DTWOPD.FOR
15181 *===dtwopd=============================================================*
15183 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15184 & COF2,SIF2,AM1,AM2)
15186 ************************************************************************
15187 * Two-particle decay. *
15188 * UMO cm-energy of the decaying system (input) *
15189 * AM1/AM2 masses of the decay products (input) *
15190 * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15191 * COD,COF,SIF direction cosines of the decay prod. (output) *
15192 * Revised by S. Roesler, 20.11.95 *
15193 ************************************************************************
15195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15197 PARAMETER ( LINP = 10 ,
15200 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15202 IF (UMO.LT.(AM1+AM2)) THEN
15203 WRITE(LOUT,1000) UMO,AM1,AM2
15204 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15209 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15211 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15213 CALL DT_DSFECF(SIF1,COF1)
15214 COD1 = TWO*DT_RNDM(PCM2)-ONE
15222 *$ CREATE DT_DTHREP.FOR
15225 *===dthrep=============================================================*
15227 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15228 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15230 ************************************************************************
15231 * Three-particle decay. *
15232 * UMO cm-energy of the decaying system (input) *
15233 * AM1/2/3 masses of the decay products (input) *
15234 * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15235 * COD,COF,SIF direction cosines of the decay prod. (output) *
15237 * Threpd89: slight revision by A. Ferrari *
15238 * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15239 * Revised by S. Roesler, 20.11.95 *
15240 ************************************************************************
15242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15244 PARAMETER ( LINP = 10 ,
15248 PARAMETER ( ANGLSQ = 2.5D-31 )
15249 PARAMETER ( AZRZRZ = 1.0D-30 )
15250 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15251 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15252 PARAMETER ( ONEONE = 1.D+00 )
15253 PARAMETER ( TWOTWO = 2.D+00 )
15254 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15256 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15257 * flags for input different options
15258 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15259 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15260 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15262 DIMENSION F(5),XX(5)
15266 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15267 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15268 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15275 * UFAK=1.0000000000001D0
15276 * IF (GU.GT.GO) UFAK=0.9999999999999D0
15294 S22=GU+(I-1.D0)*DS2
15296 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15298 IF(RHO2.LT.RHO1) GO TO 125
15300 125 S2SUP=(S22-S21)*.5D0+S21
15301 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15303 SUPRHO=SUPRHO*1.05D0
15305 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15306 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15312 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15313 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15315 X4=(XX(1)+XX(2))*0.5D0
15316 X5=(XX(2)+XX(3))*0.5D0
15317 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15319 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15326 IF (F (II).GE.F (III)) GO TO 128
15339 IF (XX(II).GE.XX(III)) GO TO 129
15353 IF (ITH.GT.200) REDU=-9.D0
15354 IF (ITH.GT.200) GO TO 400
15356 * S2=AM23+C*((UMO-AM1)**2-AM23)
15357 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15360 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15361 IF(Y.GT.RHO) GO TO 1
15362 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15364 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15366 S3=UMO2+AM11+AM22+AM33-S1-S2
15367 ECM1=(UMO2+AM11-S2)/UMOO
15368 ECM2=(UMO2+AM22-S3)/UMOO
15369 ECM3=(UMO2+AM33-S1)/UMOO
15370 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15371 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15372 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15373 CALL DT_DSFECF(SFE,CFE)
15374 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15375 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15376 PCM12 = PCM1 * PCM2
15377 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15378 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15382 COSTH=(UW-0.5D+00)*2.D+00
15384 * IF(ABS(COSTH).GT.0.9999999999999999D0)
15385 * &COSTH=SIGN(0.9999999999999999D0,COSTH)
15386 IF(ABS(COSTH).GT.ONEONE)
15387 &COSTH=SIGN(ONEONE,COSTH)
15388 IF (REDU.LT.1.D+00) RETURN
15389 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15390 * IF(ABS(COSTH2).GT.0.9999999999999999D0)
15391 * &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15392 IF(ABS(COSTH2).GT.ONEONE)
15393 &COSTH2=SIGN(ONEONE,COSTH2)
15394 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15395 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15396 SINTH1=COSTH2*SINTH-COSTH*SINTH2
15397 COSTH1=COSTH*COSTH2+SINTH2*SINTH
15398 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15399 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15400 C***THE DIRECTION OF PARTICLE 3
15401 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15408 CALL DT_DSFECF(SIF3,COF3)
15409 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15410 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15412 COD1=CX11*COD3+CZ11*SID3
15413 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15414 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15417 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15418 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15419 COD2=CX22*COD3+CZ22*SID3
15420 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15421 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15422 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15424 * === Energy conservation check: === *
15425 EOCHCK = UMO - ECM1 - ECM2 - ECM3
15426 * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15427 * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15428 * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15429 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15430 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15431 & + PCM3 * COF3 * SID3
15432 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15433 & + PCM3 * SIF3 * SID3
15434 EOCMPR = 1.D-12 * UMO
15435 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15436 & .GT. EOCMPR ) THEN
15437 **sr 5.5.95 output-unit changed
15438 IF (IOULEV(1).GT.0) THEN
15440 & ' *** Threpd: energy/momentum conservation failure! ***',
15441 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
15442 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15449 *$ CREATE DT_DBKLAS.FOR
15452 *===dbklas=============================================================*
15454 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15456 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15458 PARAMETER ( LINP = 10 ,
15462 * quark-content to particle index conversion (DTUNUC 1.x)
15463 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15464 & IA08(6,21),IA10(6,21)
15469 CALL DT_INDEXD(J,K,IND)
15472 IF (I8.LE.0) I8 = I10
15479 CALL DT_INDEXD(JJ,KK,IND)
15482 IF (I8.LE.0) I8 = I10
15487 *$ CREATE DT_INDEXD.FOR
15490 *===indexd=============================================================*
15492 SUBROUTINE DT_INDEXD(KA,KB,IND)
15494 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15496 PARAMETER ( LINP = 10 ,
15505 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15507 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15508 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15509 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15511 IF (KP.EQ.10) IND=10
15512 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15513 IF (KP.EQ.9) IND=12
15514 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15515 IF (KP.EQ.15) IND=14
15516 IF (KP.EQ.18) IND=15
15517 IF (KP.EQ.16) IND=16
15518 IF (KP.EQ.20) IND=17
15519 IF (KP.EQ.24) IND=18
15520 IF (KP.EQ.25) IND=19
15521 IF (KP.EQ.30) IND=20
15522 IF (KP.EQ.36) IND=21
15527 *$ CREATE DT_DCHANT.FOR
15530 *===dchant=============================================================*
15532 SUBROUTINE DT_DCHANT
15534 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15536 PARAMETER ( LINP = 10 ,
15539 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15541 * HADRIN: decay channel information
15542 PARAMETER (IDMAX9=602)
15544 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15545 * particle properties (BAMJET index convention)
15547 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15548 & IICH(210),IIBAR(210),K1(210),K2(210)
15550 DIMENSION HWT(IDMAX9)
15552 * change of weights wt from absolut values into the sum of wt of a dec.
15557 C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15558 C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15559 C & K1(KKK),K2(KKK)
15570 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15571 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15581 *$ CREATE DT_DDATAR.FOR
15584 *===ddatar=============================================================*
15586 SUBROUTINE DT_DDATAR
15588 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15590 PARAMETER ( LINP = 10 ,
15593 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15595 * quark-content to particle index conversion (DTUNUC 1.x)
15596 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15597 & IA08(6,21),IA10(6,21)
15599 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15601 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
15602 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
15604 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
15605 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
15607 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
15608 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
15609 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
15610 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
15611 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
15612 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
15613 & 0, 0, 0,140,137,138,146, 0, 0,142,
15614 & 139,147, 0, 0,145,148, 50*0/
15615 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
15616 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
15617 & 0, 54, 55,105,162, 0, 0, 56,106,163,
15618 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
15619 & 0, 0,104,105,107,164, 0, 0,106,108,
15620 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
15621 & 0, 0, 0,161,162,164,167, 0, 0,163,
15622 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
15623 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
15624 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
15625 & 0, 2, 9,100,149, 0, 0, 0,101,154,
15626 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
15627 & 0, 0, 99,100,102,150, 0, 0,101,103,
15628 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
15629 & 0, 0, 0,152,149,150,158, 0, 0,154,
15630 & 151,159, 0, 0,157,160, 50*0/
15631 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
15632 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
15633 & 0, 68, 69,111,172, 0, 0, 70,112,173,
15634 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
15635 & 0, 0,110,111,113,174, 0, 0,112,114,
15636 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
15637 & 0, 0, 0,171,172,174,177, 0, 0,173,
15638 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
15674 *$ CREATE DT_INITJS.FOR
15677 *===initjs=============================================================*
15679 SUBROUTINE DT_INITJS(MODE)
15681 ************************************************************************
15682 * Initialize JETSET paramters. *
15683 * MODE = 0 default settings *
15684 * = 1 PHOJET settings *
15685 * = 2 DTUNUC settings *
15686 * This version dated 16.02.96 is written by S. Roesler *
15688 * Last change 27.12.2006 by S. Roesler. *
15689 ************************************************************************
15691 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15693 PARAMETER ( LINP = 10 ,
15696 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15698 LOGICAL LFIRST,LFIRDT,LFIRPH
15700 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15701 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15702 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15703 * flags for particle decays
15704 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15705 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15706 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15707 * flags for input different options
15708 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15709 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15710 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15714 DIMENSION IDXSTA(40)
15716 * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
15717 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15718 * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
15719 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
15720 * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15721 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15722 * Ksic0 aKsic+aKsic0 sig0 asig0
15723 & 4132,-4232,-4132, 3212,-3212, 5*0/
15725 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15728 * save default settings
15740 * LUJETS / PYJETS array-dimensions
15742 * increase maximum number of JETSET-error prints
15744 * prevent particles decaying
15747 KC = PYCOMP(IDXSTA(I))
15754 C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15755 C & (I.EQ.8).OR.(I.EQ.10)) THEN
15756 C ELSEIF (I.EQ.4) THEN
15763 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15764 KC = PYCOMP(IDXSTA(I))
15773 IF (PDB.LE.ZERO) THEN
15774 * no popcorn-mechanism
15780 * set JETSET-parameter requested by input cards
15781 IF (NMSTU.GT.0) THEN
15783 MSTU(IMSTU(I)) = MSTUX(I)
15786 IF (NMSTJ.GT.0) THEN
15788 MSTJ(IMSTJ(I)) = MSTJX(I)
15791 IF (NPARU.GT.0) THEN
15793 PARU(IPARU(I)) = PARUX(I)
15799 * PARJ(1) suppression of qq-aqaq pair prod. compared to
15800 * q-aq pair prod. (default: 0.1)
15801 * PARJ(2) strangeness suppression (default: 0.3)
15802 * PARJ(3) extra suppression of strange diquarks (default: 0.4)
15803 * PARJ(6) extra suppression of sas-pair shared by B and
15804 * aB in BMaB (default: 0.5)
15805 * PARJ(7) extra suppression of strange meson M in BMaB
15806 * configuration (default: 0.5)
15807 * PARJ(18) spin 3/2 baryon suppression (default: 1.0)
15808 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15809 * momentum distrib. for prim. hadrons (default: 0.35)
15810 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15811 * function (default: 0.9 GeV^-2)
15814 IF (MODE.EQ.1) THEN
15821 C PARJ(18) = PDEF18
15822 C PARJ(21) = PDEF21
15823 C PARJ(42) = PDEF42
15824 **sr 18.11.98 parameter tuning
15825 C PARJ(1) = 0.092D0
15829 C PARJ(21) = 0.45D0
15831 **sr 28.04.99 parameter tuning (May 99 minor modifications)
15841 IF (NPARJ.GT.0) THEN
15843 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15847 WRITE(LOUT,'(1X,A)')
15848 & 'DT_INITJS: JETSET-parameter for PHOJET'
15853 ELSEIF (MODE.EQ.2) THEN
15854 IF (IFRAG(2).EQ.1) THEN
15855 **sr parameters before 9.3.96
15860 C PARJ(21) = 0.55D0
15862 **sr 18.11.98 parameter tuning
15867 C PARJ(21) = 0.45D0
15869 **sr 28.04.99 parameter tuning
15877 IF (NPARJ.GT.0) THEN
15879 IF (IPARJ(I).LT.0) THEN
15880 IDX = ABS(IPARJ(I))
15881 PARJ(IDX) = PARJX(I)
15886 WRITE(LOUT,'(1X,A)')
15887 & 'DT_INITJS: JETSET-parameter for DTUNUC'
15891 ELSEIF (IFRAG(2).EQ.2) THEN
15898 C PARJ(21) = 0.55D0
15929 *$ CREATE DT_JSPARA.FOR
15932 *===jspara=============================================================*
15934 SUBROUTINE DT_JSPARA(MODE)
15936 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15938 PARAMETER ( LINP = 10 ,
15941 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15942 & ONE=1.0D0,ZERO=0.0D0)
15946 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15948 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15950 DATA LFIRST /.TRUE./
15952 * save the default JETSET-parameter on the first call
15964 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
15966 * compare the default JETSET-parameter with the present values
15968 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
15969 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
15970 C ISTU(I) = MSTU(I)
15972 DIFF = ABS(PARU(I)-QARU(I))
15973 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
15974 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
15975 C QARU(I) = PARU(I)
15977 IF (MSTJ(I).NE.ISTJ(I)) THEN
15978 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
15979 C ISTJ(I) = MSTJ(I)
15981 DIFF = ABS(PARJ(I)-QARJ(I))
15982 IF (DIFF.GE.1.0D-5) THEN
15983 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
15984 C QARJ(I) = PARJ(I)
15987 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
15988 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
15993 *$ CREATE DT_FOZOCA.FOR
15996 *===fozoca=============================================================*
15998 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16000 ************************************************************************
16001 * This subroutine treats the complete FOrmation ZOne supressed intra- *
16002 * nuclear CAscade. *
16003 * LFZC = .true. cascade has been treated *
16004 * = .false. cascade skipped *
16005 * This is a completely revised version of the original FOZOKL. *
16006 * This version dated 18.11.95 is written by S. Roesler *
16007 ************************************************************************
16009 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16011 PARAMETER ( LINP = 10 ,
16014 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16015 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16017 LOGICAL LSTART,LCAS,LFZC
16020 PARAMETER (NMXHKK=200000)
16021 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16022 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16023 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16024 * extended event history
16025 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16026 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16028 * rejection counter
16029 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16030 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16031 & IREXCI(3),IRDIFF(2),IRINC
16032 * properties of interacting particles
16033 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16034 * Glauber formalism: collision properties
16035 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16036 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16037 * flags for input different options
16038 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16039 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16040 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16041 * final state after intranuclear cascade step
16042 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16043 * parameter for intranuclear cascade
16045 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16047 DIMENSION NCWOUN(2)
16049 DATA LSTART /.TRUE./
16054 * skip cascade if hadron-hadron interaction or if supressed by user
16055 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16056 * skip cascade if not all possible chains systems are hadronized
16058 IF (.NOT.LHADRO(I)) GOTO 9999
16062 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16063 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16064 & 'maximum of',I4,' generations',/,10X,'formation time ',
16065 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16066 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16067 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16068 1001 FORMAT(10X,'p_t dependent formation zone',/)
16069 1002 FORMAT(10X,'constant formation zone',/)
16073 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16074 * which may interact with final state particles are stored in a seperate
16075 * array - here all proj./target nucleon-indices (just for simplicity)
16077 DO 9 I=1,NPOINT(1)-1
16082 * initialize Pauli-principle treatment (find wounded nucleons)
16089 IF (ISTHKK(J).EQ.10+I) THEN
16090 NWOUND(I) = NWOUND(I)+1
16091 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16092 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16097 * modify nuclear potential for wounded nucleons
16098 IPRCL = IP -NWOUND(1)
16099 IPZRCL = IPZ-NCWOUN(1)
16100 ITRCL = IT -NWOUND(2)
16101 ITZRCL = ITZ-NCWOUN(2)
16102 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16110 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16111 * select nucleus the cascade starts first (proj. - 1, target - -1)
16113 * projectile/target with probab. 1/2
16114 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16115 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16116 * in the nucleus with highest mass
16117 ELSEIF (INCMOD.EQ.2) THEN
16120 ELSEIF (IP.EQ.IT) THEN
16121 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16123 * the nucleus the cascade starts first is requested to be the one
16124 * moving in the direction of the secondary
16125 ELSEIF (INCMOD.EQ.3) THEN
16126 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16128 * check that the selected "nucleus" is not a hadron
16129 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16130 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
16132 * treat intranuclear cascade in the nucleus selected first
16134 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16135 IF (IREJ1.NE.0) GOTO 9998
16136 * treat intranuclear cascade in the other nucleus if this isn't a had.
16138 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16139 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
16140 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16141 IF (IREJ1.NE.0) GOTO 9998
16149 IF (NSTART.LE.NEND) GOTO 7
16154 * reject this event
16159 * intranucl. cascade not treated because of interaction properties or
16160 * it is supressed by user or it was rejected or...
16162 * reset flag characterizing direction of motion in n-n-cms
16164 C DO 9990 I=NPOINT(5),NHKK
16165 C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16171 *$ CREATE DT_INUCAS.FOR
16174 *===inucas=============================================================*
16176 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16178 ************************************************************************
16179 * Formation zone supressed IntraNUclear CAScade for one final state *
16181 * IT, IP mass numbers of target, projectile nuclei *
16182 * IDXCAS index of final state particle in DTEVT1 *
16183 * NCAS = 1 intranuclear cascade in projectile *
16184 * = -1 intranuclear cascade in target *
16185 * This version dated 18.11.95 is written by S. Roesler *
16186 ************************************************************************
16188 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16190 PARAMETER ( LINP = 10 ,
16194 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16195 & OHALF=0.5D0,ONE=1.0D0)
16196 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16197 PARAMETER (TWOPI=6.283185307179586454D+00)
16198 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16200 LOGICAL LABSOR,LCAS
16203 PARAMETER (NMXHKK=200000)
16204 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16205 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16206 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16207 * extended event history
16208 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16209 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16211 * final state after inc step
16212 PARAMETER (MAXFSP=10)
16213 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16214 * flags for input different options
16215 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16216 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16217 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16218 * particle properties (BAMJET index convention)
16220 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16221 & IICH(210),IIBAR(210),K1(210),K2(210)
16222 * Glauber formalism: collision properties
16223 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16224 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16225 * nuclear potential
16227 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16228 & EBINDP(2),EBINDN(2),EPOT(2,210),
16229 & ETACOU(2),ICOUL,LFERMI
16230 * parameter for intranuclear cascade
16232 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16233 * final state after intranuclear cascade step
16234 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16235 * nucleon-nucleon event-generator
16238 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16239 * statistics: residual nuclei
16240 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16241 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16242 & NINCST(2,4),NINCEV(2),
16243 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16244 & NRESPB(2),NRESCH(2),NRESEV(4),
16245 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16248 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16249 & PCAS1(5),PNUC(5),BGTA(4),
16250 & BGCAS(2),GACAS(2),BECAS(2),
16251 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16253 DATA PDIF /0.545D0/
16258 IF (NINCEV(1).NE.NEVHKK) THEN
16260 NINCEV(2) = NINCEV(2)+1
16263 * "BAMJET-index" of this hadron
16264 IDCAS = IDBAM(IDXCAS)
16265 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16267 * skip gammas, electrons, etc..
16268 IF (AAM(IDCAS).LT.TINY2) RETURN
16270 * Lorentz-trsf. into projectile rest system
16272 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16273 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16274 & PCAS(1,4),IDCAS,-2)
16275 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16276 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16277 IF (PCAS(1,5).GT.ZERO) THEN
16278 PCAS(1,5) = SQRT(PCAS(1,5))
16280 PCAS(1,5) = AAM(IDCAS)
16283 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16285 * Lorentz-parameters
16286 * particle rest system --> projectile rest system
16287 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16288 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16289 BECAS(1) = BGCAS(1)/GACAS(1)
16293 IF (K.LE.3) COSCAS(1,K) = ZERO
16300 * Lorentz-trsf. into target rest system
16302 * LEPTO: final state particles are already in target rest frame
16303 C IF (MCGENE.EQ.3) THEN
16304 C PCAS(2,1) = PHKK(1,IDXCAS)
16305 C PCAS(2,2) = PHKK(2,IDXCAS)
16306 C PCAS(2,3) = PHKK(3,IDXCAS)
16307 C PCAS(2,4) = PHKK(4,IDXCAS)
16309 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16310 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16311 & PCAS(2,4),IDCAS,-3)
16313 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16314 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16315 IF (PCAS(2,5).GT.ZERO) THEN
16316 PCAS(2,5) = SQRT(PCAS(2,5))
16318 PCAS(2,5) = AAM(IDCAS)
16321 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16323 * Lorentz-parameters
16324 * particle rest system --> target rest system
16325 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16326 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16327 BECAS(2) = BGCAS(2)/GACAS(2)
16331 IF (K.LE.3) COSCAS(2,K) = ZERO
16339 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16340 * potential (see CONUCL)
16341 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
16342 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
16343 * impact parameter (the projectile moving along z)
16345 BIMPC(2) = BIMPAC*FM2MM
16347 * get position of initial hadron in projectile/target rest-syst.
16349 VTXCAS(1,K) = WHKK(K,IDXCAS)
16350 VTXCAS(2,K) = VHKK(K,IDXCAS)
16355 IF (NCAS.EQ.-1) THEN
16360 IF (PTOCAS(ICAS).LT.TINY10) THEN
16361 WRITE(LOUT,1000) PTOCAS
16362 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
16363 & ' hadron ',/,20X,2E12.4)
16367 * reset spectator flags
16374 * formation length (in fm)
16378 DEL0 = TAUFOR*BGCAS(ICAS)
16379 IF (ITAUVE.EQ.1) THEN
16380 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16381 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16384 * sample from exp(-del/del0)
16385 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16386 * save formation time
16387 TAUSA1 = DEL1/BGCAS(ICAS)
16388 REL1 = TAUSA1*BGCAS(I2)
16391 TAUSAM = DEL/BGCAS(ICAS)
16392 REL = TAUSAM*BGCAS(I2)
16394 * special treatment for negative particles unable to escape
16395 * nuclear potential (implemented for ap, pi-, K- only)
16397 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16398 * threshold energy = nuclear potential + Coulomb potential
16399 * (nuclear potential for hadron-nucleus interactions only)
16400 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16401 IF (PCAS(ICAS,4).LT.ETHR) THEN
16403 PCAS1(K) = PCAS(ICAS,K)
16405 * "absorb" negative particle in nucleus
16406 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16407 IF (IREJ1.NE.0) GOTO 9999
16408 IF (NSPE.GE.1) LABSOR = .TRUE.
16412 * if the initial particle has not been absorbed proceed with
16414 IF (.NOT.LABSOR) THEN
16416 * calculate coordinates of hadron at the end of the formation zone
16417 * transport-time and -step in the rest system where this step is
16420 DTIME = DSTEP/BECAS(ICAS)
16422 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16423 RTIME = RSTEP/BECAS(I2)
16427 * save step whithout considering the overlapping region
16428 DSTEP1 = DEL1*FM2MM
16429 DTIME1 = DSTEP1/BECAS(ICAS)
16430 RSTEP1 = REL1*FM2MM
16431 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16432 RTIME1 = RSTEP1/BECAS(I2)
16436 * transport to the end of the formation zone in this system
16438 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16439 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
16440 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16441 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
16443 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16444 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
16445 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16446 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
16448 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16449 XCAS = VTXCAS(ICAS,1)
16450 YCAS = VTXCAS(ICAS,2)
16451 XNCLTA = BIMPAC*FM2MM
16452 RNCLPR = (RPROJ+RNUCLE)*FM2MM
16453 RNCLTA = (RTARG+RNUCLE)*FM2MM
16454 C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16455 C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16456 C RNCLPR = (RPROJ)*FM2MM
16457 C RNCLTA = (RTARG)*FM2MM
16458 RCASPR = SQRT( XCAS**2 +YCAS**2)
16459 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16460 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16461 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16465 * check if particle is already outside of the corresp. nucleus
16466 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16467 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16468 IF (RDIST.GE.RNUC(ICAS)) THEN
16469 * here: IDCH is the generation of the final state part. starting
16470 * with zero for hadronization products
16471 * flag particles of generation 0 being outside the nuclei after
16472 * formation time (to be used for excitation energy calculation)
16473 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16474 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16483 * already here: skip particles being outside HADRIN "energy-window"
16484 * to avoid wasting of time
16485 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16486 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16487 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16488 C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16489 C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
16490 C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16491 C & E12.4,', above or below HADRIN-thresholds',I6)
16496 DO 7 IDXHKK=1,NOINC
16498 * scan DTEVT1 for unwounded or excited nucleons
16499 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16501 IF (ICAS.EQ.1) THEN
16502 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16503 ELSEIF (ICAS.EQ.2) THEN
16504 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16507 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16508 & VTXDST(2)*COSCAS(ICAS,2)+
16509 & VTXDST(3)*COSCAS(ICAS,3)
16510 * check if nucleon is situated in forward direction
16511 IF (POSNUC.GT.ZERO) THEN
16512 * distance between hadron and this nucleon
16513 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16516 BIMNU2 = DISTNU**2-POSNUC**2
16517 IF (BIMNU2.LT.ZERO) THEN
16518 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16519 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
16520 & ' parameter ',/,20X,3E12.4)
16523 BIMNU = SQRT(BIMNU2)
16524 * maximum impact parameter to have interaction
16525 IDNUC = IDT_ICIHAD(IDHKK(I))
16526 IDNUC1 = IDT_MCHAD(IDNUC)
16527 IDCAS1 = IDT_MCHAD(IDCAS)
16529 PCAS1(K) = PCAS(ICAS,K)
16530 PNUC(K) = PHKK(K,I)
16532 * Lorentz-parameter for trafo into rest-system of target
16534 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16536 * transformation of projectile into rest-system of target
16537 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16538 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16539 & PPTOT,PX,PY,PZ,PE)
16541 C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16542 C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16544 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16545 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16546 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16547 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16548 SIGIN = SIGTOT-SIGEL-SIGAB
16549 C SIGTOT = SIGIN+SIGEL+SIGAB
16551 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16552 * check if interaction is possible
16553 IF (BIMNU.LE.BIMMAX) THEN
16554 * get nucleon with smallest distance and kind of interaction
16555 * (elastic/inelastic)
16556 IF (DISTNU.LT.DIST) THEN
16559 IF (IDNUC.NE.IDSPE(1)) THEN
16560 IDSPE(2) = IDSPE(1)
16561 IDXSPE(2) = IDXSPE(1)
16570 C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16572 C STOT = SIGIN+SIGEL
16574 C SELA = SIGEL+0.75D0*SIGIN
16575 C STOT = 0.25D0*SIGIN+SELA
16581 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16583 IDNUC = IDT_ICIHAD(IDHKK(I))
16584 IF (IDNUC.EQ.1) THEN
16585 IF (DISTNU.LT.DISTP) THEN
16590 ELSEIF (IDNUC.EQ.8) THEN
16591 IF (DISTNU.LT.DISTN) THEN
16600 * there is no nucleon for a secondary interaction
16601 IF (NSPE.EQ.0) GOTO 9997
16603 C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16604 C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16605 IF (IDXSPE(2).EQ.0) THEN
16606 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16608 C IF (ICAS.EQ.1) THEN
16609 C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16610 C ELSEIF (ICAS.EQ.2) THEN
16611 C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16614 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16616 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16623 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16625 C IF (ICAS.EQ.1) THEN
16626 C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16627 C ELSEIF (ICAS.EQ.2) THEN
16628 C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16631 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16633 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16646 IF (RR.LT.SELA/STOT) THEN
16648 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16655 PCAS1(K) = PCAS(ICAS,K)
16656 PNUC(K) = PHKK(K,IDXSPE(1))
16658 IF (IPROC.EQ.3) THEN
16659 * 2-nucleon absorption of pion
16661 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16662 IF (IREJ1.NE.0) GOTO 9999
16663 IF (NSPE.GE.1) LABSOR = .TRUE.
16665 * sample secondary interaction
16666 IDNUC = IDBAM(IDXSPE(1))
16667 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16668 IF (IREJ1.EQ.1) GOTO 9999
16669 IF (IREJ1.GT.1) GOTO 9998
16673 * update arrays to include Pauli-principle
16675 IF (NWOUND(ICAS).LE.299) THEN
16676 NWOUND(ICAS) = NWOUND(ICAS)+1
16677 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16681 * dump initial hadron for energy-momentum conservation check
16683 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16684 & PCAS(ICAS,4),1,IDUM,IDUM)
16686 * dump final state particles into DTEVT1
16688 * check if Pauli-principle is fulfilled
16690 NWTMP(1) = NWOUND(1)
16691 NWTMP(2) = NWOUND(2)
16695 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16696 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16698 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16705 IF (IDX.EQ.1) MODE = -1
16706 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16708 * first check if cascade step is forbidden due to Pauli-principle
16709 * (in case of absorpion this step is forced)
16710 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16711 & (IDFSP(I).EQ.8))) THEN
16712 * get nuclear potential barrier
16713 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16714 IF (IDFSP(I).EQ.1) THEN
16715 POTLOW = POT-EBINDP(IDX)
16717 POTLOW = POT-EBINDN(IDX)
16719 * final state particle not able to escape nucleus
16720 IF (PE.LE.POTLOW) THEN
16721 * check if there are wounded nucleons
16722 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16723 & EWOUND(IDX,NWOUND(IDX)))) THEN
16725 NWOUND(IDX) = NWOUND(IDX)-1
16727 * interaction prohibited by Pauli-principle
16728 NWOUND(1) = NWTMP(1)
16729 NWOUND(2) = NWTMP(2)
16738 NWOUND(1) = NWTMP(1)
16739 NWOUND(2) = NWTMP(2)
16743 IST = ISTHKK(IDXCAS)
16747 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16748 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16750 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16755 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16757 * first check if cascade step is forbidden due to Pauli-principle
16758 * (in case of absorpion this step is forced)
16759 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16760 & (IDFSP(I).EQ.8))) THEN
16761 * get nuclear potential barrier
16762 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16763 IF (IDFSP(I).EQ.1) THEN
16764 POTLOW = POT-EBINDP(IDX)
16766 POTLOW = POT-EBINDN(IDX)
16768 * final state particle not able to escape nucleus
16769 IF (PE.LE.POTLOW) THEN
16770 * check if there are wounded nucleons
16771 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16772 & EWOUND(IDX,NWOUND(IDX)))) THEN
16773 NWOUND(IDX) = NWOUND(IDX)-1
16777 * interaction prohibited by Pauli-principle
16778 NWOUND(1) = NWTMP(1)
16779 NWOUND(2) = NWTMP(2)
16783 c ELSEIF (PE.LE.POT) THEN
16784 cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16785 cC NWOUND(IDX) = NWOUND(IDX)-1
16787 c NPAULI = NPAULI+1
16793 * dump final state particles for energy-momentum conservation check
16794 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16795 & -PFSP(4,I),2,IDUM,IDUM)
16801 IF (ABS(IST).EQ.1) THEN
16802 * transform particles back into n-n cms
16803 * LEPTO: leave final state particles in target rest frame
16804 C IF (MCGENE.EQ.3) THEN
16811 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16812 & PFSP(4,I),IDFSP(I),IMODE)
16814 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16815 * target cascade but fsp got stuck in proj. --> transform it into
16816 * proj. rest system
16817 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16818 & PFSP(4,I),IDFSP(I),-1)
16819 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16820 * proj. cascade but fsp got stuck in target --> transform it into
16821 * target rest system
16822 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16823 & PFSP(4,I),IDFSP(I),1)
16826 * dump final state particles into DTEVT1
16827 IGEN = IDCH(IDXCAS)+1
16828 ID = IDT_IPDGHA(IDFSP(I))
16830 IF (LABSOR) IXR = 99
16831 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16832 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16834 * update the counter for particles which got stuck inside the nucleus
16835 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16837 IDXINC(NOINC) = NHKK
16840 * in case of absorption the spatial treatment is an approximate
16841 * solution anyway (the positions of the nucleons which "absorb" the
16842 * cascade particle are not taken into consideration) therefore the
16843 * particles are produced at the position of the cascade particle
16845 WHKK(K,NHKK) = WHKK(K,IDXCAS)
16846 VHKK(K,NHKK) = VHKK(K,IDXCAS)
16849 * DDISTL - distance the cascade particle moves to the intera. point
16850 * (the position where impact-parameter = distance to the interacting
16851 * nucleon), DIST - distance to the interacting nucleon at the time of
16852 * formation of the cascade particle, BINT - impact-parameter of this
16853 * cascade-interaction
16854 DDISTL = SQRT(DIST**2-BINT**2)
16855 DTIME = DDISTL/BECAS(ICAS)
16856 DTIMEL = DDISTL/BGCAS(ICAS)
16857 RDISTL = DTIMEL*BGCAS(I2)
16858 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16859 RTIME = RDISTL/BECAS(I2)
16863 * RDISTL, RTIME are this step and time in the rest system of the other
16866 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16867 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
16869 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16870 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
16871 * position of particle production is half the impact-parameter to
16872 * the interacting nucleon
16874 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16875 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16877 * time of production of secondary = time of interaction
16878 WHKK(4,NHKK) = VTXCA1(1,4)
16879 VHKK(4,NHKK) = VTXCA1(2,4)
16884 * modify status and position of cascade particle (the latter for
16885 * statistics reasons only)
16887 IF (LABSOR) ISTHKK(IDXCAS) = 19
16888 IF (.NOT.LABSOR) THEN
16890 WHKK(K,IDXCAS) = VTXCA1(1,K)
16891 VHKK(K,IDXCAS) = VTXCA1(2,K)
16897 * dump interacting nucleons for energy-momentum conservation check
16899 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16901 * modify entry for interacting nucleons
16902 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16903 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16905 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16906 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16910 * check energy-momentum conservation
16912 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16913 IF (IREJ1.NE.0) GOTO 9999
16918 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16920 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16921 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16928 * transport-step but no cascade step due to configuration (i.e. there
16929 * is no nucleon for interaction etc.)
16932 C WHKK(K,IDXCAS) = VTXCAS(1,K)
16933 C VHKK(K,IDXCAS) = VTXCAS(2,K)
16934 WHKK(K,IDXCAS) = VTXCA1(1,K)
16935 VHKK(K,IDXCAS) = VTXCA1(2,K)
16940 * no cascade-step because of configuration
16941 * (i.e. hadron outside nucleus etc.)
16951 *$ CREATE DT_ABSORP.FOR
16954 *===absorp=============================================================*
16956 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16958 ************************************************************************
16959 * Two-nucleon absorption of antiprotons, pi-, and K-. *
16960 * Antiproton absorption is handled by HADRIN. *
16961 * The following channels for meson-absorption are considered: *
16962 * pi- + p + p ---> n + p *
16963 * pi- + p + n ---> n + n *
16964 * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
16965 * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
16966 * K- + p + p ---> sigma- + n *
16967 * IDCAS, PCAS identity, momentum of particle to be absorbed *
16968 * NCAS = 1 intranuclear cascade in projectile *
16969 * = -1 intranuclear cascade in target *
16970 * NSPE number of spectator nucleons involved *
16971 * IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
16972 * Revised version of the original STOPIK written by HJM and J. Ranft. *
16973 * This version dated 24.02.95 is written by S. Roesler *
16974 ************************************************************************
16976 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16978 PARAMETER ( LINP = 10 ,
16981 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
16982 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
16985 PARAMETER (NMXHKK=200000)
16986 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16987 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16988 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16989 * extended event history
16990 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16991 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16993 * flags for input different options
16994 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16995 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16996 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16997 * final state after inc step
16998 PARAMETER (MAXFSP=10)
16999 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17000 * particle properties (BAMJET index convention)
17002 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17003 & IICH(210),IIBAR(210),K1(210),K2(210)
17005 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17006 & PTOT3P(4),BG3P(4),
17007 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17012 * skip particles others than ap, pi-, K- for mode=0
17013 IF ((MODE.EQ.0).AND.
17014 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17015 * skip particles others than pions for mode=1
17016 * (2-nucleon absorption in intranuclear cascade)
17017 IF ((MODE.EQ.1).AND.
17018 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17021 IF (NUCAS.EQ.-1) NUCAS = 2
17023 IF (MODE.EQ.0) THEN
17024 * scan spectator nucleons for nucleons being able to "absorb"
17029 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17032 IDSPE(NSPE) = IDBAM(I)
17033 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17034 IF (NSPE.EQ.2) THEN
17035 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17036 & (IDSPE(2).EQ.8)) THEN
17037 * there is no pi-+n+n channel
17049 * transform excited projectile nucleons (status=15) into proj. rest s.
17052 PSPE(I,K) = PHKK(K,IDXSPE(I))
17056 * antiproton absorption
17057 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17059 PSPE1(K) = PSPE(1,K)
17061 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17062 IF (IREJ1.NE.0) GOTO 9999
17065 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17066 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17067 IF (IDCAS.EQ.14) THEN
17071 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17072 ELSEIF (IDCAS.EQ.13) THEN
17076 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17077 ELSEIF (IDCAS.EQ.23) THEN
17079 IDFSP(1) = IDSPE(1)
17080 IDFSP(2) = IDSPE(2)
17081 ELSEIF (IDCAS.EQ.16) THEN
17084 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17085 IF (R.LT.ONETHI) THEN
17088 ELSEIF (R.LT.TWOTHI) THEN
17095 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17099 IF (R.LT.ONETHI) THEN
17102 ELSEIF (R.LT.TWOTHI) THEN
17111 * dump initial particles for energy-momentum cons. check
17113 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17114 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17116 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17119 * get Lorentz-parameter of 3 particle initial state
17121 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17123 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17124 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17126 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17128 * 2-particle decay of the 3-particle compound system
17129 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17130 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17131 & AAM(IDFSP(1)),AAM(IDFSP(2)))
17133 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17134 PX = PCMF(I)*COFF(I)*SDF
17135 PY = PCMF(I)*SIFF(I)*SDF
17136 PZ = PCMF(I)*CODF(I)
17137 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17138 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17140 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17141 * check consistency of kinematics
17142 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17143 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17144 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
17145 & ' tree-particle kinematics',/,20X,'id: ',I3,
17146 & ' AAM = ',E10.4,' MFSP = ',E10.4)
17148 * dump final state particles for energy-momentum cons. check
17149 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17150 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17154 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17155 IF (IREJ1.NE.0) THEN
17156 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17162 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17163 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
17164 & ' impossible',/,20X,'too few spectators (',I2,')')
17171 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17176 *$ CREATE DT_HADRIN.FOR
17179 *===hadrin=============================================================*
17181 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17183 ************************************************************************
17184 * Interface to the HADRIN-routines for inelastic and elastic *
17186 * IDPR,PPR(5) identity, momentum of projectile *
17187 * IDTA,PTA(5) identity, momentum of target *
17188 * MODE = 1 inelastic interaction *
17189 * = 2 elastic interaction *
17190 * Revised version of the original FHAD. *
17191 * This version dated 27.10.95 is written by S. Roesler *
17192 ************************************************************************
17194 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17196 PARAMETER ( LINP = 10 ,
17199 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17200 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17202 LOGICAL LCORR,LMSSG
17204 * flags for input different options
17205 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17206 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17207 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17208 * final state after inc step
17209 PARAMETER (MAXFSP=10)
17210 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17211 * particle properties (BAMJET index convention)
17213 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17214 & IICH(210),IIBAR(210),K1(210),K2(210)
17215 * output-common for DHADRI/ELHAIN
17216 * final state from HADRIN interaction
17217 PARAMETER (MAXFIN=10)
17218 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17219 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17221 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17222 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17224 DATA LMSSG /.TRUE./
17233 * dump initial particles for energy-momentum cons. check
17235 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17236 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17239 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17240 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17241 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17242 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17243 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17244 IF (LMSSG.AND.(IOULEV(3).GT.0))
17245 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17246 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
17247 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17248 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17253 * convert initial state particles into particles which can be
17254 * handled by HADRIN
17257 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17258 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17265 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17266 IF (IREJ1.GT.0) THEN
17267 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17274 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17275 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17278 * Lorentz-parameter for trafo into rest-system of target
17280 BGTA(K) = PTA(K)/PTA(5)
17282 * transformation of projectile into rest-system of target
17283 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17284 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17287 * direction cosines of projectile in target rest system
17288 CX = PPR1(1)/PPRTO1
17289 CY = PPR1(2)/PPRTO1
17290 CZ = PPR1(3)/PPRTO1
17292 * sample inelastic interaction
17293 IF (MODE.EQ.1) THEN
17294 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17295 IF (IRH.EQ.1) GOTO 9998
17296 * sample elastic interaction
17297 ELSEIF (MODE.EQ.2) THEN
17298 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17299 IF (IREJ1.NE.0) THEN
17300 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17303 IF (IRH.EQ.1) GOTO 9998
17305 WRITE(LOUT,1001) MODE,INTHAD
17306 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
17307 & I4,' (INTHAD =',I4,')')
17311 * transform final state particles back into Lab.
17314 PX = CXRH(I)*PLRH(I)
17315 PY = CYRH(I)*PLRH(I)
17316 PZ = CZRH(I)*PLRH(I)
17317 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17318 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17319 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17320 IDFSP(NFSP) = ITRH(I)
17321 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17323 IF (AMFSP2.LT.-TINY3) THEN
17324 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17325 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17326 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
17327 & I2,') with negative mass^2',/,1X,5E12.4)
17330 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17331 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17332 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17334 1003 FORMAT(1X,'HADRIN: warning! final state particle',
17335 & ' (id = ',I2,') with inconsistent mass',/,1X,
17338 IF (KCORR.GT.2) GOTO 9999
17339 IMCORR(KCORR) = NFSP
17342 * dump final state particles for energy-momentum cons. check
17343 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17344 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17347 * transform momenta on mass shell in case of inconsistencies in
17349 IF (KCORR.GT.0) THEN
17350 IF (KCORR.EQ.2) THEN
17354 IF (IMCORR(1).EQ.1) THEN
17362 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17363 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17364 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17365 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17367 P1IN(K) = PFSP(K,I1)
17368 P2IN(K) = PFSP(K,I2)
17370 XM1 = AAM(IDFSP(I1))
17371 XM2 = AAM(IDFSP(I2))
17372 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17373 IF (IREJ1.GT.0) THEN
17374 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17378 PFSP(K,I1) = P1OUT(K)
17379 PFSP(K,I2) = P2OUT(K)
17381 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17382 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
17383 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17384 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
17385 * dump final state particles for energy-momentum cons. check
17386 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17387 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17388 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17389 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17392 * check energy-momentum conservation
17394 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17395 IF (IREJ1.NE.0) GOTO 9999
17409 *$ CREATE DT_HADCOL.FOR
17412 *===hadcol=============================================================*
17414 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17416 ************************************************************************
17417 * Interface to the HADRIN-routines for inelastic and elastic *
17418 * scattering. This subroutine samples hadron-nucleus interactions *
17419 * below DPM-threshold. *
17420 * IDPROJ BAMJET-index of projectile hadron *
17421 * PPN projectile momentum in target rest frame *
17422 * IDXTAR DTEVT1-index of target nucleon undergoing *
17423 * interaction with projectile hadron *
17424 * This subroutine replaces HADHAD. *
17425 * This version dated 5.5.95 is written by S. Roesler *
17426 ************************************************************************
17428 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17430 PARAMETER ( LINP = 10 ,
17433 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17438 PARAMETER (NMXHKK=200000)
17439 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17440 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17441 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17442 * extended event history
17443 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17444 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17446 * nuclear potential
17448 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17449 & EBINDP(2),EBINDN(2),EPOT(2,210),
17450 & ETACOU(2),ICOUL,LFERMI
17451 * interface HADRIN-DPM
17452 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17453 * parameter for intranuclear cascade
17455 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17456 * final state after inc step
17457 PARAMETER (MAXFSP=10)
17458 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17459 * particle properties (BAMJET index convention)
17461 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17462 & IICH(210),IIBAR(210),K1(210),K2(210)
17464 DIMENSION PPROJ(5),PNUC(5)
17466 DATA LSTART /.TRUE./
17473 **sr 6/9/01 commented
17474 C TAUFOR = TAUFOR/2.0D0
17478 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
17479 WRITE(LOUT,1001) TAUFOR
17480 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
17485 IDNUC = IDBAM(IDXTAR)
17486 IDNUC1 = IDT_MCHAD(IDNUC)
17487 IDPRO1 = IDT_MCHAD(IDPROJ)
17489 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17493 C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17494 C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17496 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17497 SIGIN = SIGTOT-SIGEL
17498 C SIGTOT = SIGIN+SIGEL
17501 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17507 PPROJ(5) = AAM(IDPROJ)
17508 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17510 PNUC(K) = PHKK(K,IDXTAR)
17516 IF (ILOOP.GT.100) GOTO 9999
17518 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17519 IF (IREJ1.EQ.1) GOTO 9999
17521 IF (IREJ1.GT.1) THEN
17522 * no interaction possible
17523 * require Pauli blocking
17524 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17525 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17526 IF ((IIBAR(IDPROJ).NE.1).AND.
17527 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
17528 * store incoming particle as final state particle
17529 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17530 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17533 * require Pauli blocking for final state nucleons
17535 IF ((IDFSP(I).EQ.1).AND.
17536 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
17537 IF ((IDFSP(I).EQ.8).AND.
17538 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
17539 IF ((IIBAR(IDFSP(I)).NE.1).AND.
17540 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17542 * store final state particles
17545 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17546 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17547 IDHAD = IDT_IPDGHA(IDFSP(I))
17548 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17549 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17551 IF (I.EQ.1) NPOINT(4) = NHKK
17552 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17553 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17554 VHKK(3,NHKK) = VHKK(3,IDXTAR)
17555 VHKK(4,NHKK) = VHKK(4,IDXTAR)
17556 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17557 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17558 WHKK(3,NHKK) = WHKK(3,1)
17559 WHKK(4,NHKK) = WHKK(4,1)
17571 *$ CREATE DT_GETEMU.FOR
17574 *===getemu=============================================================*
17576 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17578 ************************************************************************
17579 * Sampling of emulsion component to be considered as target-nucleus. *
17580 * This version dated 6.5.95 is written by S. Roesler. *
17581 ************************************************************************
17583 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17585 PARAMETER ( LINP = 10 ,
17588 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17590 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17591 * emulsion treatment
17592 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17594 * Glauber formalism: flags and parameters for statistics
17597 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17599 IF (MODE.EQ.0) THEN
17601 RR = DT_RNDM(SUMFRA)
17604 DO 1 ICOMP=1,NCOMPO
17605 SUMFRA = SUMFRA+EMUFRA(ICOMP)
17606 IF (SUMFRA.GT.RR) THEN
17608 ITZ = IEMUCH(ICOMP)
17615 WRITE(LOUT,'(1X,A,E12.3)')
17616 & 'Warning! norm. failure within emulsion fractions',
17620 ELSEIF (MODE.EQ.1) THEN
17623 IDIFF = ABS(IT-IEMUMA(I))
17624 IF (IDIFF.LT.NDIFF) THEN
17633 * bypass for variable projectile/target/energy runs: the correct
17634 * Glauber data will be always loaded on kkmat=1
17635 IF (IOGLB.EQ.100) THEN
17642 *$ CREATE DT_NCLPOT.FOR
17645 *===nclpot=============================================================*
17647 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17649 ************************************************************************
17650 * Calculation of Coulomb and nuclear potential for a given configurat. *
17651 * IPZ, IP charge/mass number of proj. *
17652 * ITZ, IT charge/mass number of targ. *
17653 * AFERP,AFERT factors modifying proj./target pot. *
17654 * if =0, FERMOD is used *
17655 * MODE = 0 calculation of binding energy *
17656 * = 1 pre-calculated binding energy is used *
17657 * This version dated 16.11.95 is written by S. Roesler. *
17659 * Last change 28.12.2006 by S. Roesler. *
17660 ************************************************************************
17662 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17664 PARAMETER ( LINP = 10 ,
17667 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17672 * particle properties (BAMJET index convention)
17674 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17675 & IICH(210),IIBAR(210),K1(210),K2(210)
17676 * nuclear potential
17678 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17679 & EBINDP(2),EBINDN(2),EPOT(2,210),
17680 & ETACOU(2),ICOUL,LFERMI
17682 DIMENSION IDXPOT(14)
17683 * ap an lam alam sig- sig+ sig0 tet0 tet- asig-
17684 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
17685 * asig0 asig+ atet0 atet+
17686 & 100, 101, 102, 103/
17689 DATA LSTART /.TRUE./
17691 IF (MODE.EQ.0) THEN
17703 IF (AFERP.LE.ZERO) FERMIP = FERMOD
17705 IF (AFERT.LE.ZERO) FERMIT = FERMOD
17707 * Fermi momenta and binding energy for projectile
17708 IF ((IP.GT.1).AND.LFERMI) THEN
17709 IF (MODE.EQ.0) THEN
17710 C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17711 C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17714 EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17715 & -DT_ENERGY(AIP,AIPZ))
17716 IF (AIP.LE.AIPZ) THEN
17717 EBINDN(1) = EBINDP(1)
17718 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17720 EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17721 & +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17724 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17725 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17730 * effective nuclear potential for projectile
17731 C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17732 C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17733 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17734 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17736 * Fermi momenta and binding energy for target
17737 IF ((IT.GT.1).AND.LFERMI) THEN
17738 IF (MODE.EQ.0) THEN
17739 C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17740 C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17744 EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17745 & -DT_ENERGY(AIT,AITZ))
17747 IF (AIT.LE.AITZ) THEN
17748 EBINDN(2) = EBINDP(2)
17749 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17752 EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17753 & +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17757 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17758 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17763 * effective nuclear potential for target
17764 C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17765 C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17766 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17767 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17770 EPOT(1,IDXPOT(I)) = EPOT(1,8)
17771 EPOT(2,IDXPOT(I)) = EPOT(2,8)
17777 IF (ICOUL.EQ.1) THEN
17779 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17781 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17785 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17786 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17787 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17789 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
17790 & ,' effects',/,12X,'---------------------------',
17791 & '----------------',/,/,38X,'projectile',
17792 & ' target',/,/,1X,'Mass number / charge',
17793 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
17794 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
17795 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
17796 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
17797 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
17798 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
17805 *$ CREATE DT_RESNCL.FOR
17808 *===resncl=============================================================*
17810 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17812 ************************************************************************
17813 * Treatment of residual nuclei and nuclear effects. *
17814 * MODE = 1 initializations *
17815 * = 2 treatment of final state *
17816 * This version dated 16.11.95 is written by S. Roesler. *
17818 * Last change 05.01.2007 by S. Roesler. *
17819 ************************************************************************
17821 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17823 PARAMETER ( LINP = 10 ,
17826 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17827 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17828 & ONETHI=ONE/THREE)
17829 PARAMETER (AMUAMU = 0.93149432D0,
17832 PARAMETER ( EMVGEV = 1.0 D-03 )
17833 PARAMETER ( AMUGEV = 0.93149432 D+00 )
17834 PARAMETER ( AMPRTN = 0.93827231 D+00 )
17835 PARAMETER ( AMNTRN = 0.93956563 D+00 )
17836 PARAMETER ( AMELCT = 0.51099906 D-03 )
17837 PARAMETER ( HLFHLF = 0.5D+00 )
17838 PARAMETER ( FERTHO = 14.33 D-09 )
17839 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17840 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17841 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17844 PARAMETER (NMXHKK=200000)
17845 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17846 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17847 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17848 * extended event history
17849 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17850 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17852 * particle properties (BAMJET index convention)
17854 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17855 & IICH(210),IIBAR(210),K1(210),K2(210)
17856 * flags for input different options
17857 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17858 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17859 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17860 * nuclear potential
17862 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17863 & EBINDP(2),EBINDN(2),EPOT(2,210),
17864 & ETACOU(2),ICOUL,LFERMI
17865 * properties of interacting particles
17866 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17867 * properties of photon/lepton projectiles
17868 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17869 * Lorentz-parameters of the current interaction
17870 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17871 & UMO,PPCM,EPROJ,PPROJ
17872 * treatment of residual nuclei: wounded nucleons
17873 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17874 * treatment of residual nuclei: 4-momenta
17875 LOGICAL LRCLPR,LRCLTA
17876 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17877 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17879 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17880 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17881 & IDXCOR(15000),IDXOTH(NMXHKK)
17885 *------- initializations
17888 * initialize arrays for residual nuclei
17903 * correction of projectile 4-momentum for effective target pot.
17904 * and Coulomb-energy (in case of hadron-nucleus interaction only)
17905 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17908 * positively charged hadron - check energy for Coloumb pot.
17909 IF (IICH(IJPROJ).EQ.1) THEN
17910 THRESH = ETACOU(2)+AAM(IJPROJ)
17911 IF (EPNI.LE.THRESH) THEN
17913 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
17914 & ' below Coulomb threshold - event rejected',/)
17918 * negatively charged hadron - increase energy by Coulomb energy
17919 ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17920 EPNI = EPNI+ETACOU(2)
17922 IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
17923 * Effective target potential
17924 *sr 6.6. binding energy only (to avoid negative exc. energies)
17925 C EPNI = EPNI+EPOT(2,IJPROJ)
17927 IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17928 & EBIPOT = EBINDN(2)
17929 EPNI = EPNI+ABS(EBIPOT)
17930 * re-initialization of DTLTRA
17933 CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17937 * projectile in n-n cms
17938 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17939 PMASS1 = AAM(IJPROJ)
17941 C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17942 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17944 PM1 = SIGN(PMASS1**2,PMASS1)
17945 PM2 = SIGN(PMASS2**2,PMASS2)
17946 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17948 IF (PMASS1.GT.ZERO) THEN
17949 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17950 & *(PINIPR(4)+PINIPR(5)))
17952 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17956 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17957 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17958 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17960 PMASS2 = AAM(IJTARG)
17961 PM1 = SIGN(PMASS1**2,PMASS1)
17962 PM2 = SIGN(PMASS2**2,PMASS2)
17963 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
17965 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
17966 & *(PINITA(4)+PINITA(5)))
17969 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17970 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17971 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
17974 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17975 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17978 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17979 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17984 *------- treatment of final state
17988 IF (NLOOP.GT.1) SCPOT = 0.10D0
17989 C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18001 DO 900 I=NPOINT(4),NHKK
18003 IF (ISTHKK(I).EQ.1) THEN
18004 IF (IDBAM(I).EQ.7) GOTO 900
18007 * particle moving into forward direction
18008 IF (PHKK(3,I).GE.ZERO) THEN
18009 * most likely to be effected by projectile potential
18011 * there is no projectile nucleus, try target
18012 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18014 IF (IP.GT.1) IOTHER = 1
18015 * there is no target nucleus --> skip
18016 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18018 * particle moving into backward direction
18020 * most likely to be effected by target potential
18022 * there is no target nucleus, try projectile
18023 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18025 IF (IT.GT.1) IOTHER = 1
18026 * there is no projectile nucleus --> skip
18027 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18031 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18032 * =1: particle is not in overlap-region AND is inside target (2)
18033 * =2: particle is not in overlap-region AND is inside projectile (1)
18034 * flag particles which are inside the nucleus ipot but not in its
18036 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18037 IF (IDBAM(I).NE.0) THEN
18038 * baryons: keep all nucleons and all others where flag is set
18039 IF (IIBAR(IDBAM(I)).NE.0) THEN
18040 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18043 PMOMB(NOB) = PHKK(3,I)
18044 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
18045 & +1000000*IOTHER+I,IFLG)
18047 * mesons: keep only those mesons where flag is set
18049 IF (IFLG.GT.0) THEN
18051 PMOMM(NOM) = PHKK(3,I)
18052 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
18059 * sort particles in the arrays according to increasing long. momentum
18060 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18061 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18063 * shuffle indices into one and the same array according to the later
18064 * sequence of correction
18068 IF (PMOMB(I).GT.ZERO) GOTO 911
18070 IDXCOR(NCOR) = IDXB(I)
18076 IF (PMOMB(I).LT.ZERO) GOTO 913
18078 IDXCOR(NCOR) = IDXB(I)
18083 IF (PMOMB(I).GT.ZERO) THEN
18085 IDXCOR(NCOR) = IDXB(I)
18093 IDXCOR(NCOR) = IDXB(I)
18097 IF (PMOMM(I).GT.ZERO) GOTO 926
18099 IDXCOR(NCOR) = IDXM(I)
18104 IF (PMOMM(I).LT.ZERO) GOTO 928
18106 IDXCOR(NCOR) = IDXM(I)
18110 C IF (NEVHKK.EQ.484) THEN
18111 C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18112 C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
18113 C WRITE(LOUT,9001) NOB,NOM,NCOR
18114 C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18115 C WRITE(LOUT,'(/,A)') ' baryons '
18117 CC J = IABS(IDXB(I))
18118 CC INDEX = J-IABS(J/10000000)*10000000
18119 C IPOT = IABS(IDXB(I))/10000000
18120 C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18121 C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18122 C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18124 C WRITE(LOUT,'(/,A)') ' mesons '
18126 CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18127 C IPOT = IABS(IDXM(I))/10000000
18128 C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18129 C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18130 C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18132 C 9002 FORMAT(1X,4I14,E14.5)
18133 C WRITE(LOUT,'(/,A)') ' all '
18135 CC J = IABS(IDXCOR(I))
18136 CC INDEX = J-IABS(J/10000000)*10000000
18137 CC IPOT = IABS(IDXCOR(I))/10000000
18138 C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18139 C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18140 C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18142 C 9003 FORMAT(1X,4I14)
18146 IPOT = IABS(IDXCOR(ICOR))/10000000
18147 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18148 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18153 * reduction of particle momentum by corresponding nuclear potential
18154 * (this applies only if Fermi-momenta are requested)
18158 * Lorentz-transformation into the rest system of the selected nucleus
18160 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18161 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18162 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18163 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18167 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18168 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18169 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18170 IF (IOULEV(3).GT.0)
18171 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18172 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
18173 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18174 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
18182 * the correction for nuclear potential effects is applied to as many
18183 * p/n as many nucleons were wounded; the momenta of other final state
18184 * particles are corrected only if they materialize inside the corresp.
18185 * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18186 * = 3 part. outside proj. and targ., >=10 in overlapping region)
18187 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18188 IF (IPOT.EQ.1) THEN
18189 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18190 * this is most likely a wounded nucleon
18192 C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18193 C & +(VHKK(2,IPW(JPW))/FM2MM)**2
18194 C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
18195 C RAD = RNUCLE*DBLE(IP)**ONETHI
18196 C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18197 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18199 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18203 * correct only if part. was materialized inside nucleus
18204 * and if it is ouside the overlapping region
18205 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18206 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18210 ELSEIF (IPOT.EQ.2) THEN
18211 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18212 * this is most likely a wounded nucleon
18214 C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18215 C & +(VHKK(2,ITW(JTW))/FM2MM)**2
18216 C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
18217 C RAD = RNUCLE*DBLE(IT)**ONETHI
18218 C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18219 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18221 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18225 * correct only if part. was materialized inside nucleus
18226 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18227 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18233 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18234 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18239 IF (NLOOP.EQ.1) THEN
18240 * Coulomb energy correction:
18241 * the treatment of Coulomb potential correction is similar to the
18242 * one for nuclear potential
18243 IF (IDSEC.EQ.1) THEN
18244 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18246 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18249 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18252 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18254 IF (IICH(IDSEC).EQ.1) THEN
18255 * pos. particles: check if they are able to escape Coulomb potential
18256 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18257 ISTHKK(I) = 14+IPOT
18258 IF (ISTHKK(I).EQ.15) THEN
18260 PHKK(K,I) = PSEC0(K)
18261 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18263 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18264 IF (IDSEC.EQ.1) NPCW = NPCW-1
18265 ELSEIF (ISTHKK(I).EQ.16) THEN
18267 PHKK(K,I) = PSEC0(K)
18268 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18270 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18271 IF (IDSEC.EQ.1) NTCW = NTCW-1
18275 ELSEIF (IICH(IDSEC).EQ.-1) THEN
18276 * neg. particles: decrease energy by Coulomb-potential
18277 PSEC(4) = PSEC(4)-ETACOU(IPOT)
18284 IF (PSEC(4).LT.AMSEC) THEN
18285 IF (IOULEV(6).GT.0)
18286 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18287 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18288 & ' is not allowed to escape nucleus',/,
18289 & 8X,'id : ',I3,' reduced energy: ',E15.4,
18291 ISTHKK(I) = 14+IPOT
18292 IF (ISTHKK(I).EQ.15) THEN
18294 PHKK(K,I) = PSEC0(K)
18295 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18297 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18298 IF (IDSEC.EQ.1) NPCW = NPCW-1
18299 ELSEIF (ISTHKK(I).EQ.16) THEN
18301 PHKK(K,I) = PSEC0(K)
18302 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18304 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18305 IF (IDSEC.EQ.1) NTCW = NTCW-1
18310 IF (JPMOD.EQ.1) THEN
18311 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18312 * 4-momentum after correction for nuclear potential
18314 PSEC(K) = PSEC(K)*PSECN/PSECO
18317 * store recoil momentum from particles escaping the nuclear potentials
18319 IF (IPOT.EQ.1) THEN
18320 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18321 ELSEIF (IPOT.EQ.2) THEN
18322 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18326 * transform momentum back into n-n cms
18328 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18329 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18337 PFSP(K) = PFSP(K)+PHKK(K,I)
18342 DO 33 I=NPOINT(4),NHKK
18343 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18344 PFSP(1) = PFSP(1)+PHKK(1,I)
18345 PFSP(2) = PFSP(2)+PHKK(2,I)
18346 PFSP(3) = PFSP(3)+PHKK(3,I)
18347 PFSP(4) = PFSP(4)+PHKK(4,I)
18352 PRCLPR(K) = TRCLPR(K)
18353 PRCLTA(K) = TRCLTA(K)
18356 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18357 * hadron-nucleus interactions: get residual momentum from energy-
18358 * momentum conservation
18361 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18364 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18365 * accumulated recoil momenta of particles leaving the spectators
18366 * transform accumulated recoil momenta of residual nuclei into
18370 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18373 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18374 C IF (IP.GT.1) THEN
18375 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18376 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18379 PRCLTA(3) = PRCLTA(3)+PINITA(3)
18380 PRCLTA(4) = PRCLTA(4)+PINITA(4)
18384 * check momenta of residual nuclei
18386 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18388 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18390 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18392 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18394 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18395 **sr 19.12. changed to avoid output when used with phojet
18398 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18399 C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18400 C & CALL DT_EVTOUT(4)
18401 IF (IREJ1.GT.0) RETURN
18407 *$ CREATE DT_SCN4BA.FOR
18410 *===scn4ba=============================================================*
18412 SUBROUTINE DT_SCN4BA
18414 ************************************************************************
18415 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
18416 * This version dated 12.12.95 is written by S. Roesler. *
18417 ************************************************************************
18419 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18421 PARAMETER ( LINP = 10 ,
18424 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18428 PARAMETER (NMXHKK=200000)
18429 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18430 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18431 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18432 * extended event history
18433 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18434 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18436 * particle properties (BAMJET index convention)
18438 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18439 & IICH(210),IIBAR(210),K1(210),K2(210)
18440 * properties of interacting particles
18441 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18442 * nuclear potential
18444 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18445 & EBINDP(2),EBINDN(2),EPOT(2,210),
18446 & ETACOU(2),ICOUL,LFERMI
18447 * treatment of residual nuclei: wounded nucleons
18448 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18449 * treatment of residual nuclei: 4-momenta
18450 LOGICAL LRCLPR,LRCLTA
18451 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18452 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18454 DIMENSION PLAB(2,5),PCMS(4)
18458 * get number of wounded nucleons
18475 * projectile nucleons wounded in primary interaction and in fzc
18476 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18480 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18481 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
18482 C IF (IP.GT.1) THEN
18484 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18487 * target nucleons wounded in primary interaction and in fzc
18488 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18492 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18493 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
18496 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18499 ELSEIF (ISTHKK(I).EQ.13) THEN
18501 ELSEIF (ISTHKK(I).EQ.14) THEN
18506 DO 11 I=NPOINT(4),NHKK
18507 * baryons which are unable to escape the nuclear potential of proj.
18508 IF (ISTHKK(I).EQ.15) THEN
18511 IF (IIBAR(IDBAM(I)).NE.0) THEN
18513 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18516 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18518 * baryons which are unable to escape the nuclear potential of targ.
18519 ELSEIF (ISTHKK(I).EQ.16) THEN
18522 IF (IIBAR(IDBAM(I)).NE.0) THEN
18524 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18527 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18532 * residual nuclei so far
18536 * ckeck for "residual nuclei" consisting of one nucleon only
18537 * treat it as final state particle
18538 IF (IRESP.EQ.1) THEN
18540 IST = ISTHKK(ISGLPR)
18541 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18542 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18543 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18544 IF (IST.EQ.13) THEN
18545 ISTHKK(ISGLPR) = 11
18549 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18550 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18551 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18552 NOBAM(NHKK) = NOBAM(ISGLPR)
18553 JDAHKK(1,ISGLPR) = NHKK
18555 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18558 IF (IREST.EQ.1) THEN
18560 IST = ISTHKK(ISGLTA)
18561 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18562 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18563 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18564 IF (IST.EQ.14) THEN
18565 ISTHKK(ISGLTA) = 12
18569 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18570 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18571 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18572 NOBAM(NHKK) = NOBAM(ISGLTA)
18573 JDAHKK(1,ISGLTA) = NHKK
18575 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18579 * get nuclear potential corresp. to the residual nucleus
18584 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18586 * baryons unable to escape the nuclear potential are treated as
18587 * excited nucleons (ISTHKK=15,16)
18588 DO 3 I=NPOINT(4),NHKK
18589 IF (ISTHKK(I).EQ.1) THEN
18591 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18592 * final state n and p not being outside of both nuclei are considered
18595 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
18596 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
18597 * Lorentz-trsf. into proj. rest sys. for those being inside proj.
18598 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18599 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18601 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18602 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18603 & (PLAB(1,4)+PLABT) ))
18604 EKIN = PLAB(1,4)-PLAB(1,5)
18605 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18606 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18608 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
18609 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
18610 * Lorentz-trsf. into targ. rest sys. for those being inside targ.
18611 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18612 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18614 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18615 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18616 & (PLAB(2,4)+PLABT) ))
18617 EKIN = PLAB(2,4)-PLAB(2,5)
18618 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18619 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18621 IF (PHKK(3,I).GE.ZERO) THEN
18623 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18626 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18628 IF (ISTHKK(I).NE.1) THEN
18631 PHKK(K,I) = PLAB(J,K)
18633 IF (ISTHKK(I).EQ.15) THEN
18635 IF (ID.EQ.1) NPCW = NPCW-1
18637 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18639 ELSEIF (ISTHKK(I).EQ.16) THEN
18641 IF (ID.EQ.1) NTCW = NTCW-1
18643 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18651 * again: get nuclear potential corresp. to the residual nucleus
18656 c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18657 cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18658 c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18660 c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18661 cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18662 c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18664 C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18665 C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18666 C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18667 C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18668 AFERP = FERMOD+0.1D0
18669 AFERT = FERMOD+0.1D0
18671 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18676 *$ CREATE DT_FICONF.FOR
18679 *===ficonf=============================================================*
18681 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18683 ************************************************************************
18684 * Treatment of FInal CONFiguration including evaporation, fission and *
18685 * Fermi-break-up (for light nuclei only). *
18686 * Adopted from the original routine FINALE and extended to residual *
18687 * projectile nuclei. *
18688 * This version dated 12.12.95 is written by S. Roesler. *
18690 * Last change 27.12.2006 by S. Roesler. *
18691 ************************************************************************
18693 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18695 PARAMETER ( LINP = 10 ,
18698 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18699 PARAMETER (ANGLGB=5.0D-16)
18700 PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18703 PARAMETER (NMXHKK=200000)
18704 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18705 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18706 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18707 * extended event history
18708 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18709 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18711 * rejection counter
18712 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18713 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18714 & IREXCI(3),IRDIFF(2),IRINC
18715 * central particle production, impact parameter biasing
18716 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18717 * particle properties (BAMJET index convention)
18719 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18720 & IICH(210),IIBAR(210),K1(210),K2(210)
18721 * treatment of residual nuclei: 4-momenta
18722 LOGICAL LRCLPR,LRCLTA
18723 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18724 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18725 * treatment of residual nuclei: properties of residual nuclei
18726 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18727 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18728 & NTOTFI(2),NPROFI(2)
18729 * statistics: residual nuclei
18730 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18731 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18732 & NINCST(2,4),NINCEV(2),
18733 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18734 & NRESPB(2),NRESCH(2),NRESEV(4),
18735 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18737 * flags for input different options
18738 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18739 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18740 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18741 * (original name: FINUC)
18742 PARAMETER (MXP=999)
18743 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
18744 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18745 & TKI (MXP), PLR (MXP), WEI (MXP),
18746 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18748 * (original name: RESNUC)
18749 LOGICAL LRNFSS, LFRAGM
18750 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18751 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18752 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
18753 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
18754 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18755 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18756 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18757 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18759 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
18760 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
18761 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18762 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18763 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18764 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18765 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
18766 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
18767 * (original name: PAREVT)
18768 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18769 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18770 PARAMETER ( NALLWP = 39 )
18771 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18772 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18773 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18774 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18776 COMMON /DTEVNO/ NEVENT,ICASCA
18778 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18779 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18780 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18782 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18784 DATA EXC,NEXC /520*ZERO,520*0/
18785 DATA EXPNUC /4.0D-3,4.0D-3/
18791 * skip residual nucleus treatment if not requested or in case
18792 * of central collisions
18793 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18820 * number of final state particles
18821 IF (ABS(ISTHKK(I)).EQ.1) THEN
18826 * properties of remaining nucleon configurations
18828 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18829 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18831 IF (MO1(KF).EQ.0) MO1(KF) = I
18833 * position of residual nucleus = average position of nucleons
18835 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18836 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18838 * total number of particles contributing to each residual nucleus
18839 NTOT(KF) = NTOT(KF)+1
18842 * total charge of residual nuclei
18843 NQ(KF) = NQ(KF)+IICH(IDTMP)
18844 * number of protons
18845 IF (IDHKK(I).EQ.2212) THEN
18846 NPRO(KF) = NPRO(KF)+1
18847 * number of neutrons
18848 ELSEIF (IDHKK(I).EQ.2112) THEN
18851 * number of baryons other than n, p
18852 IF (IIBAR(IDTMP).EQ.1) THEN
18854 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18856 * any other mesons (status set to 1)
18857 C WRITE(LOUT,1002) KF,IDTMP
18858 C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
18859 C & ' containing meson ',I4,', status set to 1')
18862 IDXTMP = IDXPAR(KF)
18863 NTOT(KF) = NTOT(KF)-1
18867 IDXPAR(KF) = IDXTMP
18871 * reject elastic events (def: one final state particle = projectile)
18872 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18873 IREXCI(3) = IREXCI(3)+1
18878 * check if one nucleus disappeared..
18879 C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18881 C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18884 C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18886 C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18895 * get the average of the nucleon positions
18896 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18897 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18898 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18899 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18901 * mass number and charge of residual nuclei
18902 AIF(I) = DBLE(NTOT(I))
18903 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18904 IF (NTOT(I).GT.1) THEN
18905 * masses of residual nuclei in ground state
18906 AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18907 * masses of residual nuclei
18908 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18909 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18910 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18912 * M_res^2 < 0 : configuration not allowed
18914 * a) re-calculate E_exc with scaled nuclear potential
18915 * (conditional jump to label 9998)
18916 * b) or reject event if N_loop(max) is exceeded
18917 * (conditional jump to label 9999)
18919 IF (AMRCL(I).LE.ZERO) THEN
18920 IF (IOULEV(3).GT.0)
18921 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18923 1000 FORMAT(1X,'warning! negative excitation energy',/,
18927 IF (NLOOP.LE.500) THEN
18930 IREXCI(2) = IREXCI(2)+1
18934 * 0 < M_res < M_res0 : mass below ground-state mass
18936 * a) we had residual nuclei with mass N_tot and reasonable E_exc
18937 * before- assign average E_exc of those configurations to this
18938 * one ( Nexc(i,N_tot) > 0 )
18939 * b) or (and this applies always if run in transport codes) go up
18940 * one mass number and
18941 * i) if mass now larger than proj/targ mass or if run in
18942 * transport codes assign average E_exc per wounded nucleon
18943 * x number of wounded nucleons (Inuc-Ntot)
18944 * ii) or assign average E_exc of those configurations to this
18945 * one ( Nexc(i,m) > 0 )
18947 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18949 M = MIN(NTOT(I),260)
18950 IF (NEXC(I,M).GT.0) THEN
18951 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18955 **sr corrected 27.12.06
18956 * IF (M.GE.INUC(I)) THEN
18957 * AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18958 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18959 IF ( INUC (I) .GT. NTOT (I) ) THEN
18960 AMRCL(I) = AMRCL0(I)
18961 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
18963 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
18967 IF (NEXC(I,M).GT.0) THEN
18968 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18974 EEXC(I) = AMRCL(I)-AMRCL0(I)
18977 * M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
18979 * a) re-calculate E_exc with scaled nuclear potential
18980 * (conditional jump to label 9998)
18981 * b) or reject event if N_loop(max) is exceeded
18982 * (conditional jump to label 9999)
18985 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
18986 IF (IOULEV(3).GT.0)
18987 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
18988 1004 FORMAT(1X,'warning! too high excitation energy',/,
18989 & I4,1P,2E15.4,3I5)
18992 IF (NLOOP.LE.500) THEN
18995 IREXCI(2) = IREXCI(2)+1
18999 * Otherwise (reasonable E_exc) :
19000 * E_exc = M_res - M_res0
19001 * in addition: calculate and save E_exc per wounded nucleon as
19002 * well as E_exc in <E_exc> counter
19005 * excitation energies of residual nuclei
19006 EEXC(I) = AMRCL(I)-AMRCL0(I)
19007 **sr 27.12.06 new excitation energy correction by A.F.
19009 * all parts with Ilcopt<3 commented since not used
19011 * still to be done/decided:
19012 * Increase Icor and put back both residual nuclei on mass shell
19013 * with the exciting correction further below.
19014 * For the moment the modification in the excitation energy is simply
19015 * corrected by scaling the energy of the residual nucleus.
19020 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19021 IF ( ILCOPT .LE. 2 ) THEN
19022 C* Patch for Fermi momentum reduction correlated with impact parameter:
19023 C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19024 C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19025 C AKPRHO = ONE - DLKPRH
19026 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19027 C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
19029 C* REDORI = 0.75D+00
19031 C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19034 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19035 * Take out roughly one/half of the skin:
19036 RDCORE = RDCORE - 0.5D+00
19038 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19039 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19040 FRCFLL = ONE - PRSKIN
19041 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19042 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19044 IF ( NNCHIT .GT. 0 ) THEN
19045 C IF ( ILCOPT .EQ. 1 ) THEN
19046 C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19047 C DO 1220 NCH = 1, 10
19048 C ETAETA = ( ONE - SKINRH**INUC(I)
19049 C & - DBLE(INUC(I))* ( ONE - FRCFLL )
19050 C & * ( ONE - SKINRH ) )
19051 C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
19052 C & * ( ONE - FRCFLL) * SKINRH )
19053 C SKINRH = SKINRH * ( ONE + ETAETA )
19055 C PRSKIN = SKINRH**(NNCHIT-1)
19056 C ELSE IF ( ILCOPT .EQ. 2 ) THEN
19057 C PRSKIN = ONE - FRCFLL
19060 DO 1230 NCH = 1, NNCHIT
19061 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19062 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19063 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19065 PRFRMI = ( ONE - 2.D+00 * DLKPRH
19066 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19068 REDCTN = REDCTN + PRFRMI**2
19070 REDCTN = REDCTN / DBLE (NNCHIT)
19074 EEXC (I) = EEXC (I) * REDCTN / REDORI
19075 AMRCL (I) = AMRCL0 (I) + EEXC (I)
19076 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19079 IF (ICASCA.EQ.0) THEN
19080 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19081 M = MIN(NTOT(I),260)
19082 EXC(I,M) = EXC(I,M)+EEXC(I)
19083 NEXC(I,M) = NEXC(I,M)+1
19086 ELSEIF (NTOT(I).EQ.1) THEN
19088 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
19098 PRCLPR(5) = AMRCL(1)
19099 PRCLTA(5) = AMRCL(2)
19101 IF (ICOR.GT.0) THEN
19102 IF (INORCL.EQ.0) THEN
19103 * one or both residual nuclei consist of one nucleon only, transform
19104 * this nucleon on mass shell
19106 P1IN(K) = PRCL(1,K)
19107 P2IN(K) = PRCL(2,K)
19111 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19112 IF (IREJ1.GT.0) THEN
19113 WRITE(LOUT,*) 'ficonf-mashel rejection'
19117 PRCL(1,K) = P1OUT(K)
19118 PRCL(2,K) = P2OUT(K)
19119 PRCLPR(K) = P1OUT(K)
19120 PRCLTA(K) = P2OUT(K)
19122 PRCLPR(5) = AMRCL(1)
19123 PRCLTA(5) = AMRCL(2)
19125 IF (IOULEV(3).GT.0)
19126 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19127 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19128 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19129 & AMRCL(2),AMRCL(2)-AMRCL0(2)
19130 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
19131 & ' correction',/,11X,'at event',I8,
19132 & ', nucleon config. 1:',2I4,' 2:',2I4,
19134 IF (NLOOP.LE.500) THEN
19137 IREXCI(1) = IREXCI(1)+1
19143 C IF (NRESEV(1).NE.NEVHKK) THEN
19144 C NRESEV(1) = NEVHKK
19145 C NRESEV(2) = NRESEV(2)+1
19147 NRESEV(2) = NRESEV(2)+1
19149 EXCDPM(I) = EXCDPM(I)+EEXC(I)
19150 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19151 NRESTO(I) = NRESTO(I)+NTOT(I)
19152 NRESPR(I) = NRESPR(I)+NPRO(I)
19153 NRESNU(I) = NRESNU(I)+NN(I)
19154 NRESBA(I) = NRESBA(I)+NH(I)
19155 NRESPB(I) = NRESPB(I)+NHPOS(I)
19156 NRESCH(I) = NRESCH(I)+NQ(I)
19162 * initialize evaporation counter
19164 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19165 & (EEXC(I).GT.ZERO)) THEN
19166 * put residual nuclei into DTEVT1
19168 JMASS = INT( AIF(I))
19169 JCHAR = INT(AIZF(I))
19170 * the following patch is required to transmit the correct excitation
19172 IF (ITRSPT.EQ.1) THEN
19173 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19174 & (IOULEV(3).GT.0))
19176 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19177 & AMRCL(I),AMRCL0(I),EEXC(I)
19179 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19181 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19183 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19186 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19187 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19192 VHKK(J,NHKK) = VRCL(I,J)
19193 WHKK(J,NHKK) = WRCL(I,J)
19195 * interface to evaporation module - fill final residual nucleus into
19197 * fill resnuc only if code is not used as event generator in Fluka
19198 IF (ITRSPT.NE.1) THEN
19202 IBRES = NPRO(I)+NN(I)+NH(I)
19203 ICRES = NPRO(I)+NHPOS(I)
19206 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
19207 * ground state mass of the residual nucleus (should be equal to AM0T)
19209 AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19212 * kinetic energy of residual nucleus
19213 TVRECL = PRCL(I,4)-AMRCL(I)
19214 * excitation energy of residual nucleus
19217 PTRES = SQRT(ABS(TVRECL*(TVRECL+
19218 & 2.0D0*(AMMRES+TVCMS))))
19219 IF (PTOLD.LT.ANGLGB) THEN
19220 CALL DT_RACO(PXRES,PYRES,PZRES)
19223 PXRES = PXRES*PTRES/PTOLD
19224 PYRES = PYRES*PTRES/PTOLD
19225 PZRES = PZRES*PTRES/PTOLD
19226 * zero counter of secondaries from evaporation
19231 * put evaporated particles and residual nuclei to DTEVT1
19233 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19236 EXCEVA(I) = EXCEVA(I)+EXCITF
19243 C9998 IREXCI(1) = IREXCI(1)+1
19252 *$ CREATE DT_EVA2HE.FOR
19255 *====eva2he============================================================*
19257 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19259 ************************************************************************
19260 * Interface between common's of evaporation module (FKFINU,FKFHVY) *
19262 * MO DTEVT1-index of "mother" (residual) nucleus before evap. *
19263 * EEXCF exitation energy of residual nucleus after evaporation *
19264 * IRCL = 1 projectile residual nucleus *
19265 * = 2 target residual nucleus *
19266 * This version dated 19.04.95 is written by S. Roesler. *
19268 * Last change 27.12.2006 by S. Roesler. *
19269 ************************************************************************
19271 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19273 PARAMETER ( LINP = 10 ,
19276 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19279 PARAMETER (NMXHKK=200000)
19280 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19281 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19282 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19283 * Note: DTEVT2 - special use for heavy fragments !
19284 * (IDRES(I) = mass number, IDXRES(I) = charge)
19285 * extended event history
19286 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19287 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19289 * particle properties (BAMJET index convention)
19291 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19292 & IICH(210),IIBAR(210),K1(210),K2(210)
19293 * flags for input different options
19294 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19295 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19296 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19297 * statistics: residual nuclei
19298 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19299 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19300 & NINCST(2,4),NINCEV(2),
19301 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19302 & NRESPB(2),NRESCH(2),NRESEV(4),
19303 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19305 * treatment of residual nuclei: properties of residual nuclei
19306 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19307 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19308 & NTOTFI(2),NPROFI(2)
19309 * (original name: FINUC)
19310 PARAMETER (MXP=999)
19311 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
19312 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19313 & TKI (MXP), PLR (MXP), WEI (MXP),
19314 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19316 * (original name: FHEAVY,FHEAVC)
19317 PARAMETER ( MXHEAV = 100 )
19319 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19320 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19321 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19322 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
19323 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
19324 & IBHEAV ( 12 ) , NPHEAV
19325 COMMON /FKFHVC/ ANHEAV ( 12 )
19326 * (original name: RESNUC)
19327 LOGICAL LRNFSS, LFRAGM
19328 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19329 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19330 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19331 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
19332 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19333 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19334 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19335 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19338 DIMENSION IPTOKP(39)
19339 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19340 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19341 & 100, 101, 97, 102, 98, 103, 109, 115 /
19345 * skip if evaporation package is not included
19346 IF (.NOT.LEVAPO) RETURN
19349 IF (NRESEV(3).NE.NEVHKK) THEN
19351 NRESEV(4) = NRESEV(4)+1
19355 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19357 * mass number/charge of residual nucleus before evaporation
19361 * protons/neutrons/gammas
19366 ID = IPTOKP(KPART(I))
19367 IDPDG = IDT_IPDGHA(ID)
19368 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19369 & (2.0D0*MAX(TKI(I),TINY10))
19370 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19371 WRITE(LOUT,1000) ID,AM,AAM(ID)
19372 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
19373 & 'particle',I3,2E10.3)
19376 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19378 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19379 IBTOT = IBTOT-IIBAR(ID)
19380 IZTOT = IZTOT-IICH(ID)
19385 PX = CXHEAV(I)*PHEAVY(I)
19386 PY = CYHEAV(I)*PHEAVY(I)
19387 PZ = CZHEAV(I)*PHEAVY(I)
19389 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19390 & (2.0D0*MAX(TKHEAV(I),TINY10))
19392 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19393 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19395 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19396 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19397 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19400 IF (IBRES.GT.0) THEN
19401 * residual nucleus after evaporation
19403 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19408 NTOTFI(IRCL) = IBRES
19409 NPROFI(IRCL) = ICRES
19410 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19411 IBTOT = IBTOT-IBRES
19412 IZTOT = IZTOT-ICRES
19414 * count events with fission
19415 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19416 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19418 * energy-momentum conservation check
19419 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19420 C IF (IREJ.GT.0) THEN
19421 C CALL DT_EVTOUT(4)
19422 C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19424 * baryon-number/charge conservation check
19425 IF (IBTOT+IZTOT.NE.0) THEN
19426 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19427 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
19428 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
19434 *$ CREATE DT_EBIND.FOR
19437 *===ebind==============================================================*
19439 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19441 ************************************************************************
19442 * Binding energy for nuclei. *
19443 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
19445 * IZ atomic number *
19446 * This version dated 5.5.95 is updated by S. Roesler. *
19447 ************************************************************************
19449 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19451 PARAMETER ( LINP = 10 ,
19454 PARAMETER (ZERO=0.0D0)
19456 DATA A1, A2, A3, A4, A5
19457 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19459 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19460 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
19465 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19466 & -A4*(IA-2*IZ)**2/AA
19467 IF (MOD(IA,2).EQ.1) THEN
19469 ELSEIF (MOD(IZ,2).EQ.1) THEN
19474 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19479 **sr 30.6. routine replaced completely
19480 *$ CREATE DT_ENERGY.FOR
19483 *=== energy ===========================================================*
19485 DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19487 C INCLUDE '(DBLPRC)'
19489 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19491 * (original name: GLOBAL)
19492 PARAMETER ( KALGNM = 2 )
19493 PARAMETER ( ANGLGB = 5.0D-16 )
19494 PARAMETER ( ANGLSQ = 2.5D-31 )
19495 PARAMETER ( AXCSSV = 0.2D+16 )
19496 PARAMETER ( ANDRFL = 1.0D-38 )
19497 PARAMETER ( AVRFLW = 1.0D+38 )
19498 PARAMETER ( AINFNT = 1.0D+30 )
19499 PARAMETER ( AZRZRZ = 1.0D-30 )
19500 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19501 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19502 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19503 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19504 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
19505 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
19506 PARAMETER ( CSNNRM = 2.0D-15 )
19507 PARAMETER ( DMXTRN = 1.0D+08 )
19508 PARAMETER ( ZERZER = 0.D+00 )
19509 PARAMETER ( ONEONE = 1.D+00 )
19510 PARAMETER ( TWOTWO = 2.D+00 )
19511 PARAMETER ( THRTHR = 3.D+00 )
19512 PARAMETER ( FOUFOU = 4.D+00 )
19513 PARAMETER ( FIVFIV = 5.D+00 )
19514 PARAMETER ( SIXSIX = 6.D+00 )
19515 PARAMETER ( SEVSEV = 7.D+00 )
19516 PARAMETER ( EIGEIG = 8.D+00 )
19517 PARAMETER ( ANINEN = 9.D+00 )
19518 PARAMETER ( TENTEN = 10.D+00 )
19519 PARAMETER ( HLFHLF = 0.5D+00 )
19520 PARAMETER ( ONETHI = ONEONE / THRTHR )
19521 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19522 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19523 PARAMETER ( THRTWO = THRTHR / TWOTWO )
19524 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19525 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19526 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19527 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19528 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19529 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19530 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19531 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
19532 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
19533 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
19534 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
19535 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19536 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19537 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19538 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19539 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19540 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19541 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19542 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19543 PARAMETER ( CLIGHT = 2.99792458 D+10 )
19544 PARAMETER ( AVOGAD = 6.0221367 D+23 )
19545 PARAMETER ( BOLTZM = 1.380658 D-23 )
19546 PARAMETER ( AMELGR = 9.1093897 D-28 )
19547 PARAMETER ( PLCKBR = 1.05457266 D-27 )
19548 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19549 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19550 PARAMETER ( AMUGRM = 1.6605402 D-24 )
19551 PARAMETER ( AMMUMU = 0.113428913 D+00 )
19552 PARAMETER ( AMPRMU = 1.007276470 D+00 )
19553 PARAMETER ( AMNEMU = 1.008664904 D+00 )
19554 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19555 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19556 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19557 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19558 PARAMETER ( PLABRC = 0.197327053 D+00 )
19559 PARAMETER ( AMELCT = 0.51099906 D-03 )
19560 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19561 PARAMETER ( AMMUON = 0.105658389 D+00 )
19562 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19563 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19564 PARAMETER ( AMDEUT = 1.87561339 D+00 )
19565 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19567 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19568 PARAMETER ( BLTZMN = 8.617385 D-14 )
19569 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19570 PARAMETER ( GFOHB3 = 1.16639 D-05 )
19571 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19572 PARAMETER ( SIN2TW = 0.2319 D+00 )
19573 PARAMETER ( GEVMEV = 1.0 D+03 )
19574 PARAMETER ( EMVGEV = 1.0 D-03 )
19575 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
19576 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19577 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19578 LOGICAL LGBIAS, LGBANA
19579 COMMON /FKGLOB/ LGBIAS, LGBANA
19580 C INCLUDE '(DIMPAR)'
19582 PARAMETER ( MXXRGN = 5000 )
19583 PARAMETER ( MXXMDF = 82 )
19584 PARAMETER ( MXXMDE = 54 )
19585 PARAMETER ( MFSTCK = 1000 )
19586 PARAMETER ( MESTCK = 100 )
19587 PARAMETER ( NALLWP = 39 )
19588 PARAMETER ( NELEMX = 80 )
19589 PARAMETER ( MPDPDX = 8 )
19590 PARAMETER ( ICOMAX = 180 )
19591 PARAMETER ( NSTBIS = 304 )
19592 PARAMETER ( IDMAXP = 220 )
19593 PARAMETER ( IDMXDC = 640 )
19594 PARAMETER ( MKBMX1 = 1 )
19595 PARAMETER ( MKBMX2 = 1 )
19596 C INCLUDE '(IOUNIT)'
19598 PARAMETER ( LUNIN = 5 )
19599 PARAMETER ( LUNOUT = 6 )
19600 **sr 19.5. set error output-unit from 15 to 6
19601 PARAMETER ( LUNERR = 6 )
19602 PARAMETER ( LUNBER = 14 )
19603 PARAMETER ( LUNECH = 8 )
19604 PARAMETER ( LUNFLU = 13 )
19605 PARAMETER ( LUNGEO = 16 )
19606 PARAMETER ( LUNPMF = 12 )
19607 PARAMETER ( LUNRAN = 2 )
19608 PARAMETER ( LUNXSC = 9 )
19609 PARAMETER ( LUNDET = 17 )
19610 PARAMETER ( LUNRAY = 10 )
19611 PARAMETER ( LUNRDB = 1 )
19612 PARAMETER ( LUNPGO = 7 )
19613 PARAMETER ( LUNPGS = 4 )
19614 PARAMETER ( LUNSCR = 3 )
19616 *----------------------------------------------------------------------*
19618 * Revised version of the original routine from EVAP: *
19620 * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
19623 * Last change on 19-sep-95 by Alfredo Ferrari *
19625 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19626 * !!! It is supposed to be used with the updated atomic !!! *
19627 * !!! mass data file !!! *
19628 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19630 *----------------------------------------------------------------------*
19632 * Mass number below which "unknown" isotopes out of the Z-interval
19633 * reported in the mass tabulations are completely unstable and made
19634 * up by Z proton masses + N neutron masses:
19635 PARAMETER ( KAFREE = 4 )
19636 * Mass number below which "unknown" isotopes out of the Z-interval
19637 * reported in the mass tabulations are supposed to be particle unstable
19638 PARAMETER ( KAPUNS = 12 )
19639 * Minimum energy required for particle unstable isotopes
19640 PARAMETER ( DEPUNS = 0.5D+00 )
19642 * (original name: EVA0)
19643 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19644 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19645 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19646 * T (4,7), RMASS (297), ALPH (297), BET (297),
19647 * APRIME (250), IA (6), IZ (6)
19648 * (original name: ISOTOP)
19649 PARAMETER ( NAMSMX = 270 )
19650 PARAMETER ( NZGVAX = 15 )
19651 PARAMETER ( NISMMX = 574 )
19652 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
19653 & WAPISM (NISMMX), T12ISM (NISMMX),
19654 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19655 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
19656 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19657 & INWAPS (NAMSMX), JSPISM (NISMMX),
19658 & JPTISM (NISMMX), IZWISM (NISMMX),
19659 & INWISM (0:NAMSMX)
19661 CPH SAVE KA0, KZ0, IZ0
19662 DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19666 *======================================================================*
19668 * Entry ENergy - KNOWn *
19670 *======================================================================*
19671 ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19679 * +-------------------------------------------------------------------*
19680 * | Null residual nucleus:
19681 IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19682 IF ( IFLAG .EQ. 1 ) THEN
19690 * +-------------------------------------------------------------------*
19692 ELSE IF ( N .LE. 0 ) THEN
19693 IF ( N .LT. 0 ) THEN
19694 WRITE ( LUNOUT, * )
19695 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19697 WRITE ( LUNOUT, * )
19698 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19701 & ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19703 STOP 'DT_ENERGY:KA0-KZ0'
19706 IF ( IFLAG .EQ. 1 ) THEN
19707 DT_ENERGY = Z * WAPS ( 1, 2 )
19709 DT_ENKNOW = Z * WAPS ( 1, 2 )
19714 * +-------------------------------------------------------------------*
19716 ELSE IF ( KZ0 .LE. 0 ) THEN
19717 IF ( KZ0 .LT. 0 ) THEN
19718 WRITE ( LUNOUT, * )
19719 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19720 WRITE ( LUNOUT, * )
19721 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19723 &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19724 STOP 'DT_ENERGY:KZ0<0'
19727 IF ( IFLAG .EQ. 1 ) THEN
19728 DT_ENERGY = A * WAPS ( 1, 1 )
19730 DT_ENKNOW = A * WAPS ( 1, 1 )
19736 * +-------------------------------------------------------------------*
19737 * +-------------------------------------------------------------------*
19738 * | No actual nucleus
19740 * +-------------------------------------------------------------------*
19741 * +-------------------------------------------------------------------*
19742 * | A larger than maximum allowed:
19743 IF ( KA0 .GT. NAMSMX ) THEN
19745 IF ( IFLAG .EQ. 1 ) THEN
19746 DT_ENERGY = DT_ENRG( A, Z )
19748 DT_ENKNOW = DT_ENRG( A, Z )
19754 * +-------------------------------------------------------------------*
19755 IZZ = INWAPS ( KA0 )
19756 * +-------------------------------------------------------------------*
19757 * | Too much neutron rich with respect to the stability line:
19758 IF ( KZ0 .LT. IZZ ) THEN
19759 * | +----------------------------------------------------------------*
19760 * | | Up to A=Kafree all "bound" masses are known, set it unbound:
19761 IF ( KA0 .LE. KAFREE ) THEN
19764 * | +----------------------------------------------------------------*
19765 * | | Up to Kapuns: be sure it is particle unstable
19766 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19767 * | | Exp. excess mass for A,IZZ
19768 ENEEXP = WAPS ( KA0, 1 )
19769 * | | Cameron excess mass for A, IZZ
19770 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19771 * | | Cameron excess mass for A, Z
19772 DT_ENERGY = DT_ENRG( A, Z )
19773 * | | Use just the difference according to Cameron!!!
19774 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19775 JZZ = INWAPS ( KA0 - 1 )
19776 LZZ = INWAPS ( KA0 - 2 )
19777 * | | +-------------------------------------------------------------*
19778 * | | | Residual mass for n-decay known:
19779 IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19780 IZ0 = KZ0 - JZZ + 1
19781 DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19784 * | | +-------------------------------------------------------------*
19785 * | | | Residual mass for 2n-decay known:
19786 ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19787 IZ0 = KZ0 - LZZ + 1
19788 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19789 & ( WAPS (1,1) + DEPUNS ) )
19791 * | | +-------------------------------------------------------------*
19792 * | | | Set it unbound:
19797 * | | +-------------------------------------------------------------*
19799 * | +----------------------------------------------------------------*
19800 * | | Proceed as usual:
19802 * | | Exp. excess mass for A,IZZ
19803 ENEEXP = WAPS ( KA0, 1 )
19804 * | | Cameron excess mass for A, IZZ
19805 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19806 * | | Cameron excess mass for A, Z
19807 DT_ENERGY = DT_ENRG( A, Z )
19808 * | | Use just the difference according to Cameron!!!
19809 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19812 * | +----------------------------------------------------------------*
19813 * | Be sure not to have a positive energy state:
19814 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19816 IF ( IFLAG .EQ. 2 ) THEN
19817 DT_ENKNOW = DT_ENERGY
19822 * +-------------------------------------------------------------------*
19823 * | Too much proton rich with respect to the stability line:
19824 ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19825 * | +----------------------------------------------------------------*
19826 * | | Up to A=Kafree all "bound" masses are known, set it unbound:
19827 IF ( KA0 .LE. KAFREE ) THEN
19830 * | +----------------------------------------------------------------*
19831 * | | Up to Kapuns: be sure it is particle unstable
19832 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19833 * | | Exp. excess mass for A,IZZ+NZGVAX-1
19834 ENEEXP = WAPS ( KA0, NZGVAX )
19835 * | | Cameron excess mass for A, IZZ+NZGVAX-1
19836 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19837 * | | Cameron excess mass for A, Z
19838 DT_ENERGY = DT_ENRG( A, Z )
19839 * | | Use just the difference according to Cameron!!!
19840 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19841 JZZ = INWAPS ( KA0 - 1 )
19842 LZZ = INWAPS ( KA0 - 2 )
19843 * | | +-------------------------------------------------------------*
19844 * | | | Residual mass for p-decay known:
19845 IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19846 IZ0 = KZ0 - 1 - JZZ + 1
19847 DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19850 * | | +-------------------------------------------------------------*
19851 * | | | Residual mass for 2p-decay known:
19852 ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19854 IZ0 = KZ0 - 2 - LZZ + 1
19855 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19856 & ( WAPS (1,2) + DEPUNS ) )
19858 * | | +-------------------------------------------------------------*
19859 * | | | Set it unbound:
19864 * | | +-------------------------------------------------------------*
19866 * | +----------------------------------------------------------------*
19867 * | | Proceed as usual:
19869 * | | Exp. excess mass for A,IZZ+NZGVAX-1
19870 ENEEXP = WAPS ( KA0, NZGVAX )
19871 * | | Cameron excess mass for A, IZZ+NZGVAX-1
19872 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19873 * | | Cameron excess mass for A, Z
19874 DT_ENERGY = DT_ENRG( A, Z )
19875 * | | Use just the difference according to Cameron!!!
19876 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19879 * | +----------------------------------------------------------------*
19880 * | Be sure not to have a positive energy state:
19881 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19883 IF ( IFLAG .EQ. 2 ) THEN
19884 DT_ENKNOW = DT_ENERGY
19889 * +-------------------------------------------------------------------*
19890 * | Known isotope or anyway isotope "inside" the stability zone
19892 IZ0 = KZ0 - IZZ + 1
19893 DT_ENERGY = WAPS ( KA0, IZ0 )
19894 IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19895 * | +----------------------------------------------------------------*
19896 * | | Mass not known
19897 IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19899 IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19900 * | | +-------------------------------------------------------------*
19901 * | | | Set it unbound:
19902 IF ( KA0 .LE. KAFREE ) THEN
19905 * | | +-------------------------------------------------------------*
19906 * | | | Try to get a reasonable excess mass:
19909 * | | | +----------------------------------------------------------*
19910 * | | | | Check the closest one known:
19911 DO 500 JZZ = 1, NZGVAX
19912 IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19913 & ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19914 IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19917 * | | | +----------------------------------------------------------*
19919 * | | | Exp. excess mass for A,IZZ+JZ0-1
19920 ENEEXP = WAPS ( KA0, JZ0 )
19921 * | | | Cameron excess mass for A, IZZ+JZ0-1
19922 ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19923 * | | | Cameron excess mass for A, Z
19924 DT_ENERGY = DT_ENRG( A, Z )
19925 * | | | Use just the difference according to Cameron!!!
19926 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19930 * | | +-------------------------------------------------------------*
19931 * | | Be sure not to have a positive energy state:
19932 DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19935 * | +----------------------------------------------------------------*
19936 IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19940 * +-------------------------------------------------------------------*
19941 *=== End of Function Energy ===========================================*
19946 *$ CREATE DT_ENRG.FOR
19949 *=== enrg =============================================================*
19951 DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19953 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19956 PARAMETER ( ZERZER = 0.D+00 )
19957 PARAMETER ( ONEONE = 1.D+00 )
19958 PARAMETER ( LUNIN = 5 )
19959 PARAMETER ( LUNOUT = 6 )
19961 *----------------------------------------------------------------------*
19963 * Revised version of the original routine from EVAP: *
19965 * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
19968 * Last change on 01-oct-94 by Alfredo Ferrari *
19970 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19971 * !!! It is supposed to be used with the updated atomic !!! *
19972 * !!! mass data file !!! *
19973 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19975 *----------------------------------------------------------------------*
19977 PARAMETER ( O16OLD = 931.145 D+00 )
19978 PARAMETER ( O16NEW = 931.19826D+00 )
19979 PARAMETER ( O16RAT = O16NEW / O16OLD )
19980 PARAMETER ( C12NEW = 931.49432D+00 )
19981 PARAMETER ( ADJUST = -8.322737768178909D-02 )
19982 PARAMETER ( AINFNT = 1.0D+30 )
19983 * (original name: EVA0)
19984 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19985 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19986 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19987 * T (4,7), RMASS (297), ALPH (297), BET (297),
19988 * APRIME (250), IA (6), IZ (6)
19990 CPH SAVE LFIRST, EXHYDR, EXNEUT
19991 DATA LFIRST / .TRUE. /
19996 C EXHYDR = DT_ENERGY( ONEONE, ONEONE )
19997 C EXNEUT = DT_ENERGY( ONEONE, ZERZER )
20005 IF ( IZ0 .LE. 0 ) THEN
20006 DT_ENRG = A * EXNEUT
20010 IF ( N .LE. 0 ) THEN
20011 DT_ENRG = Z * EXHYDR
20015 AM2ZOA=AM2ZOA*AM2ZOA
20016 A13 = RMASS(NINT(A))
20017 * A13 = A**.3333333333333333D+00
20019 EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20020 ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20021 & (1.D+00 -0.62025D+00*AM13*AM13)*
20022 & (A13*A13 -.62025D+00)
20023 EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20024 & AM13-1.5849D+00)*
20025 & AM13*AM13 +1.D+00)
20026 EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20027 & (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20029 DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20030 DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20031 DT_ENRG = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20033 *=== End of function Enrg =============================================*
20036 *$ CREATE DT_INCINI.FOR
20039 *=== incini ===========================================================*
20041 SUBROUTINE DT_INCINI
20043 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20046 PARAMETER ( ZERZER = 0.D+00 )
20047 PARAMETER ( ONEONE = 1.D+00 )
20048 PARAMETER ( TWOTWO = 2.D+00 )
20049 PARAMETER ( THRTHR = 3.D+00 )
20050 PARAMETER ( FOUFOU = 4.D+00 )
20051 PARAMETER ( EIGEIG = 8.D+00 )
20052 PARAMETER ( ANINEN = 9.D+00 )
20053 PARAMETER ( HLFHLF = 0.5D+00 )
20054 PARAMETER ( ONETHI = ONEONE / THRTHR )
20055 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20056 PARAMETER ( PLABRC = 0.197327053 D+00 )
20057 PARAMETER ( AMELCT = 0.51099906 D-03 )
20058 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20059 PARAMETER ( AMPRTN = 0.93827231 D+00 )
20060 PARAMETER ( AMNTRN = 0.93956563 D+00 )
20061 PARAMETER ( AMDEUT = 1.87561339 D+00 )
20062 PARAMETER ( EMVGEV = 1.0 D-03 )
20064 PARAMETER ( LUNOUT = 6 )
20066 *----------------------------------------------------------------------*
20068 * Created on 10 june 1990 by Alfredo Ferrari & Paola Sala *
20071 * Last change on 02-may-95 by Alfredo Ferrari *
20074 *----------------------------------------------------------------------*
20076 * (original name: FHEAVY,FHEAVC)
20077 PARAMETER ( MXHEAV = 100 )
20079 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20080 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20081 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20082 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
20083 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
20084 & IBHEAV ( 12 ) , NPHEAV
20085 COMMON /FKFHVC/ ANHEAV ( 12 )
20086 * (original name: INPFLG)
20087 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20088 * (original name: FRBKCM)
20089 PARAMETER ( MXFFBK = 6 )
20090 PARAMETER ( MXZFBK = 9 )
20091 PARAMETER ( MXNFBK = 10 )
20092 PARAMETER ( MXAFBK = 16 )
20093 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20094 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20095 PARAMETER ( NXAFBK = MXAFBK + 1 )
20096 PARAMETER ( MXPSST = 300 )
20097 PARAMETER ( MXPSFB = 41000 )
20098 LOGICAL LFRMBK, LNCMSS
20099 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20100 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20101 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20102 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20103 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20104 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20105 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20106 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20107 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20108 * (original name: NUCDAT)
20109 PARAMETER ( AMUAMU = AMUGEV )
20110 PARAMETER ( AMPROT = AMPRTN )
20111 PARAMETER ( AMNEUT = AMNTRN )
20112 PARAMETER ( AMELEC = AMELCT )
20113 PARAMETER ( R0NUCL = 1.12 D+00 )
20114 PARAMETER ( RCCOUL = 1.7 D+00 )
20115 PARAMETER ( FERTHO = 14.33 D-09 )
20116 PARAMETER ( EXPEBN = 2.39 D+00 )
20117 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20118 PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20119 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
20120 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
20121 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
20122 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20123 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20124 PARAMETER ( GAMMIN = 1.0D-06 )
20125 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20126 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20127 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
20128 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
20129 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20130 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20131 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20132 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20133 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
20134 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
20135 * (original name: PAREVT)
20136 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20137 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20138 PARAMETER ( NALLWP = 39 )
20139 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20140 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20141 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20142 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20143 * (original name: NUCOLD)
20144 COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20145 & EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20151 APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20152 AMNUCL (1) = AMPROT
20153 AMNUCL (2) = AMNEUT
20154 AMNUSQ (1) = AMPROT * AMPROT
20155 AMNUSQ (2) = AMNEUT * AMNEUT
20156 AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20158 * ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20159 AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20160 AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20161 & ( 5.6D+00 * ASQHLP ) )
20162 AV0WEL = AEFRMX + EBNDAV
20163 EBNDNG (1) = EBNDAV
20164 EBNDNG (2) = EBNDAV
20165 AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20166 CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20167 AMMC12 = 12.D+00 * AMUGEV + AEXC12
20168 AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20169 AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20170 CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20171 AMMO16 = 16.D+00 * AMUGEV + AEXO16
20172 AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20173 AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20174 CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20175 AMMS28 = 28.D+00 * AMUGEV + AEXS28
20176 AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20177 AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20178 CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20179 AMMC40 = 40.D+00 * AMUGEV + AEXC40
20180 AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20181 AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20182 CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20183 AMMF56 = 56.D+00 * AMUGEV + AEXF56
20184 AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20185 AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20186 CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20187 AMM107 = 107.D+00 * AMUGEV + AEX107
20188 AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20189 AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20190 CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20191 AMM132 = 132.D+00 * AMUGEV + AEX132
20192 AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20193 AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20194 CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20195 AMM181 = 181.D+00 * AMUGEV + AEX181
20196 AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20197 AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20198 CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20199 AMM208 = 208.D+00 * AMUGEV + AEX208
20200 AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20201 AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20202 CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20203 AMM238 = 238.D+00 * AMUGEV + AEX238
20204 AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20206 AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20207 AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20208 AMHEAV (3) = TWOTWO * AMUGEV
20209 & + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20210 AMHEAV (4) = THRTHR * AMUGEV
20211 & + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20212 AMHEAV (5) = THRTHR * AMUGEV
20213 & + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20214 AMHEAV (6) = FOUFOU * AMUGEV
20215 & + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20216 ELBNDE (0) = ZERZER
20217 ELBNDE (1) = 13.6D-09
20218 DO 2000 IZ = 2, 100
20219 ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
20221 AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20222 AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20223 AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20224 AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20225 AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20226 AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20228 WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20229 & ' activated **** '
20230 IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20231 & ' production activated **** '
20233 * commented, since obsolete
20234 C IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20235 C & ' transport activated **** '
20236 IF ( IFISS .GT. 0 )
20237 & WRITE ( LUNOUT, * )' **** High Energy fission ',
20238 & ' requested & activated **** '
20240 & WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20241 & ' requested & activated **** '
20242 IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20250 *=== End of subroutine incini =========================================*
20253 *$ CREATE DT_STALIN.FOR
20256 *=== stalin ===========================================================*
20258 SUBROUTINE DT_STALIN
20260 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20262 PARAMETER ( ANGLGB = 5.0D-16 )
20263 PARAMETER ( ZERZER = 0.D+00 )
20264 PARAMETER ( ONEONE = 1.D+00 )
20265 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20266 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20267 PARAMETER ( EMVGEV = 1.0 D-03 )
20268 PARAMETER ( NSTBIS = 304 )
20269 PARAMETER ( LUNIN = 5 )
20270 PARAMETER ( LUNOUT = 6 )
20272 *----------------------------------------------------------------------*
20274 * STAbility LINe calculation: *
20276 * Created on 04 december 1992 by Alfredo Ferrari & Paola Sala *
20279 * Last change on 04-dec-92 by Alfredo Ferrari *
20282 *----------------------------------------------------------------------*
20284 * (original name: ISOTOP)
20285 PARAMETER ( NAMSMX = 270 )
20286 PARAMETER ( NZGVAX = 15 )
20287 PARAMETER ( NISMMX = 574 )
20288 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20289 & WAPISM (NISMMX), T12ISM (NISMMX),
20290 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20291 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20292 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20293 & INWAPS (NAMSMX), JSPISM (NISMMX),
20294 & JPTISM (NISMMX), IZWISM (NISMMX),
20295 & INWISM (0:NAMSMX)
20297 DIMENSION ZNORM (260)
20298 * +-------------------------------------------------------------------*
20302 ASTLIN (J,IZ) = ZERZER
20306 * +-------------------------------------------------------------------*
20307 * +-------------------------------------------------------------------*
20310 ZNORM (IA) = ZERZER
20312 ZSTLIN (J,IA) = ZERZER
20316 * +-------------------------------------------------------------------*
20317 * +-------------------------------------------------------------------*
20318 * | Loop on the Atomic Number
20320 AMSSST (IZ) = ZERZER
20323 * | +----------------------------------------------------------------*
20324 * | | Loop on the stable isotopes
20325 DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20327 ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20328 ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20329 ZNORM (IA) = ZNORM (IA) + ABUISO (IS)
20330 ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20331 ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20333 IF ( AHELP .LE. 1.00001D+00 ) THEN
20334 ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20337 AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20338 & + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20341 * | +----------------------------------------------------------------*
20342 AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20343 * | Normalize and print A_stab versus Z data:
20344 ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20346 * WRITE (LUNOUT,*)' Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20347 * & ' Sigma_st',SNGL(ASTLIN(2,IZ))
20350 * +-------------------------------------------------------------------*
20351 * +-------------------------------------------------------------------*
20352 * | Normalize and print Z_stab versus A data:
20354 ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20355 ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20356 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20357 IF ( ZNORM (IA) .GT. ANGLGB )
20358 **sr 2.11. avoid underflows at Pentium
20360 & MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20361 C & ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20365 * +-------------------------------------------------------------------*
20366 * +-------------------------------------------------------------------*
20367 * | Normalize and print Z_stab versus A data:
20369 IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20370 DO 4200 JA = IA-1,1,-1
20371 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20377 DO 4400 JA = IA+1,260
20378 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20386 ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20387 & * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20389 ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20390 & * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20393 IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20394 ATOZ = IZ / ASTLIN (1,IZ)
20395 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20396 * WRITE (LUNOUT,*)' A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20397 * & ' Sigma_st',SNGL(ZSTLIN(2,IA))
20400 * +-------------------------------------------------------------------*
20404 *$ CREATE DT_BERTTP.FOR
20407 *=== berttp ===========================================================*
20409 SUBROUTINE DT_BERTTP
20411 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20414 PARAMETER ( CSNNRM = 2.0D-15 )
20415 PARAMETER ( ZERZER = 0.D+00 )
20416 PARAMETER ( ONEONE = 1.D+00 )
20417 PARAMETER ( THRTHR = 3.D+00 )
20418 PARAMETER ( SIXSIX = 6.D+00 )
20419 PARAMETER ( ONETHI = ONEONE / THRTHR )
20420 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20421 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20422 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20423 PARAMETER ( EMVGEV = 1.0 D-03 )
20425 PARAMETER ( NSTBIS = 304 )
20427 PARAMETER ( LUNIN = 5 )
20428 PARAMETER ( LUNOUT = 6 )
20429 **sr 19.5. set error output-unit from 15 to 6
20430 PARAMETER ( LUNERR = 6 )
20431 C---------------------------------------------------------------------
20432 C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20433 C---------------------------------------------------------------------
20434 C ---------------------------------- I-N-C DATA
20435 C COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20436 C REAL*8 R8,R8B,CRSC,CS
20438 C --------------------------------- EVAPORATION DATA
20439 * (original name: COOKCM)
20440 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20441 LOGICAL LDEFOZ, LDEFON
20442 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20443 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20444 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20445 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20446 * (original name: EVA0)
20447 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20448 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20449 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20450 * T (4,7), RMASS (297), ALPH (297), BET (297),
20451 * APRIME (250), IA (6), IZ (6)
20452 * (original name: FRBKCM)
20453 PARAMETER ( MXFFBK = 6 )
20454 PARAMETER ( MXZFBK = 9 )
20455 PARAMETER ( MXNFBK = 10 )
20456 PARAMETER ( MXAFBK = 16 )
20457 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20458 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20459 PARAMETER ( NXAFBK = MXAFBK + 1 )
20460 PARAMETER ( MXPSST = 300 )
20461 PARAMETER ( MXPSFB = 41000 )
20462 LOGICAL LFRMBK, LNCMSS
20463 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20464 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20465 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20466 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20467 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20468 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20469 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20470 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20471 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20472 * (original name: HETTP)
20473 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
20474 * (original name: INPFLG)
20475 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20476 * (original name: ISOTOP)
20477 PARAMETER ( NAMSMX = 270 )
20478 PARAMETER ( NZGVAX = 15 )
20479 PARAMETER ( NISMMX = 574 )
20480 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20481 & WAPISM (NISMMX), T12ISM (NISMMX),
20482 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20483 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20484 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20485 & INWAPS (NAMSMX), JSPISM (NISMMX),
20486 & JPTISM (NISMMX), IZWISM (NISMMX),
20487 & INWISM (0:NAMSMX)
20488 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20489 PARAMETER ( PI = PIPIPI )
20490 PARAMETER ( PISQ = PIPISQ )
20491 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20492 PARAMETER ( RZNUCL = 1.12 D+00 )
20493 PARAMETER ( RMSPRO = 0.8 D+00 )
20494 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
20495 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20497 PARAMETER ( RLLE04 = RZNUCL )
20498 PARAMETER ( RLLE16 = RZNUCL )
20499 PARAMETER ( RLGT16 = RZNUCL )
20500 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20501 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20502 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20503 PARAMETER ( SKLE04 = 1.4D+00 )
20504 PARAMETER ( SKLE16 = 1.9D+00 )
20505 PARAMETER ( SKGT16 = 2.4D+00 )
20506 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20507 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20508 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20509 PARAMETER ( ALPHA0 = 0.1D+00 )
20510 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20511 PARAMETER ( GAMSK0 = 0.9D+00 )
20512 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20513 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20514 PARAMETER ( POTBA0 = 1.D+00 )
20515 PARAMETER ( PNFRAT = 1.533D+00 )
20516 PARAMETER ( RADPIM = 0.035D+00 )
20517 PARAMETER ( RDPMHL = 14.D+00 )
20518 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20519 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20520 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20521 PARAMETER ( AP0PFS = 0.5D+00 )
20522 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20523 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20524 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20525 PARAMETER ( MXSCIN = 50 )
20526 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20527 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20528 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20529 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20530 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20531 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20533 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20534 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20535 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20536 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20537 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20538 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20539 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20540 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20541 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20542 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20543 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20544 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20545 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20546 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20547 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20548 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20549 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20550 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20551 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20552 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20553 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20554 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20555 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20556 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20557 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20558 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
20559 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20560 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20561 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20562 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20563 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20564 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20565 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20566 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20567 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20568 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20569 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20570 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20571 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20572 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20574 DIMENSION AWSTAB (2:260), SIGMAB (3)
20575 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20576 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20577 EQUIVALENCE ( RHOIPP, RHONCP (1) )
20578 EQUIVALENCE ( RHOINP, RHONCP (2) )
20579 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20580 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20581 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20582 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20583 EQUIVALENCE ( RHOIPT, RHONCT (1) )
20584 EQUIVALENCE ( RHOINT, RHONCT (2) )
20585 EQUIVALENCE ( OMALHL, SK3PAR )
20586 EQUIVALENCE ( ALPHAL, HABPAR )
20587 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20588 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20589 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20590 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20591 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20592 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20593 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20594 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20595 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20596 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20597 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20598 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20599 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20600 * (original name: NUCLEV)
20601 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20602 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20603 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20604 & CUMRAD (0:160,2), RUSNUC (2),
20605 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20606 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20607 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20608 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20609 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20610 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20611 & LFLVSL, LRLVSL, LEQSBL
20612 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20613 & MGSSPR (19) , MGSSNE (25)
20614 EQUIVALENCE ( RUSNUC (1), RUSPRO )
20615 EQUIVALENCE ( RUSNUC (2), RUSNEU )
20616 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20617 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20618 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20619 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20620 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20621 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20622 EQUIVALENCE ( NTANUC (1), NTAPRO )
20623 EQUIVALENCE ( NTANUC (2), NTANEU )
20624 EQUIVALENCE ( NAVNUC (1), NAVPRO )
20625 EQUIVALENCE ( NAVNUC (2), NAVNEU )
20626 EQUIVALENCE ( NLSNUC (1), NLSPRO )
20627 EQUIVALENCE ( NLSNUC (2), NLSNEU )
20628 EQUIVALENCE ( NCONUC (1), NCOPRO )
20629 EQUIVALENCE ( NCONUC (2), NCONEU )
20630 EQUIVALENCE ( NSKNUC (1), NSKPRO )
20631 EQUIVALENCE ( NSKNUC (2), NSKNEU )
20632 EQUIVALENCE ( NHANUC (1), NHAPRO )
20633 EQUIVALENCE ( NHANUC (2), NHANEU )
20634 EQUIVALENCE ( NUSNUC (1), NUSPRO )
20635 EQUIVALENCE ( NUSNUC (2), NUSNEU )
20636 EQUIVALENCE ( NACNUC (1), NACPRO )
20637 EQUIVALENCE ( NACNUC (2), NACNEU )
20638 EQUIVALENCE ( JMXNUC (1), JMXPRO )
20639 EQUIVALENCE ( JMXNUC (2), JMXNEU )
20640 EQUIVALENCE ( MAGNUC (1), MAGPRO )
20641 EQUIVALENCE ( MAGNUC (2), MAGNEU )
20642 * (original name: PAREVT)
20643 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20644 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20645 PARAMETER ( NALLWP = 39 )
20646 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20647 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20648 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20649 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20650 * (original name: XSEPAR)
20651 COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20652 & DDNXSE (100), EENXSE (100), ZZNXSE (100),
20653 & EMNXSE (100), XMNXSE (100),
20654 & AAPXSE (100), BBPXSE (100), CCPXSE (100),
20655 & DDPXSE (100), EEPXSE (100), FFPXSE (100),
20656 & ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20658 C---------------------------------------------------------------------
20660 * modified for use in DPMJET
20661 C WRITE( LUNOUT,'(A,I2)')
20662 C & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20664 IF (LEVPRT) WRITE(LUNOUT,1000)
20665 1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20666 & /,12X,'------------------------------------',/)
20668 OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
20671 *!!!! changed to be able to read the ASCII !!!!
20673 C A. Ferrari: first of all read isotopic data
20674 READ (NBERNW,*) ISONDX
20675 READ (NBERNW,*) ISOMNM
20676 READ (NBERNW,*) ABUISO
20677 C READ (NBERTP) ISONDX
20678 C READ (NBERTP) ISOMNM
20679 C READ (NBERTP) ABUISO
20681 C READ (NBERTP) (CRSC(J,I),J=1,600)
20682 C A. Ferrari: commented also the dummy read to save disk space
20686 C A. Ferrari: commented also the dummy read to save disk space
20688 C---------------------------------------------------------------------
20689 READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20690 READ (NBERNW,*) IA,IZ
20695 READ (NBERNW,*) RHO,OMEGA
20696 READ (NBERNW,*) EXMASS
20697 READ (NBERNW,*) CAM2
20698 READ (NBERNW,*) CAM3
20699 READ (NBERNW,*) CAM4
20700 READ (NBERNW,*) CAM5
20701 READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20705 READ (NBERNW,*) RMASS
20706 READ (NBERNW,*) ALPH
20707 READ (NBERNW,*) BET
20708 READ (NBERNW,*) INWAPS
20709 READ (NBERNW,*) WAPS
20710 READ (NBERNW,*) T12NUC
20711 READ (NBERNW,*) JSPNUC
20712 READ (NBERNW,*) JPTNUC
20713 READ (NBERNW,*) INWISM
20714 READ (NBERNW,*) IZWISM
20715 READ (NBERNW,*) WAPISM
20716 READ (NBERNW,*) T12ISM
20717 READ (NBERNW,*) JSPISM
20718 READ (NBERNW,*) JPTISM
20719 READ (NBERNW,*) APRIME
20721 &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20722 READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20723 IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20724 & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20726 & ' *** Inconsistent Nuclear Geometry data on file ***'
20729 READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20730 & EKATAB, PFATAB, PFRTAB
20731 READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20733 READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20734 & ZZPXSE, EMPXSE, XMPXSE
20735 * Data about Fermi-breakup:
20736 READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20737 IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20738 & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20739 WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20740 & ' in the Nuclear Data file ***'
20741 STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20743 READ (NBERNW,*) IFRBKN
20744 READ (NBERNW,*) IFRBKZ
20745 READ (NBERNW,*) IFBKSP
20746 READ (NBERNW,*) IFBKST
20747 READ (NBERNW,*) EEXFBK
20749 CLOSE (UNIT=NBERNW)
20751 C READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20752 C READ (NBERTP) IA,IZ
20757 C READ (NBERTP) RHO,OMEGA
20758 C READ (NBERTP) EXMASS
20759 C READ (NBERTP) CAM2
20760 C READ (NBERTP) CAM3
20761 C READ (NBERTP) CAM4
20762 C READ (NBERTP) CAM5
20763 C READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20767 C READ (NBERTP) RMASS
20768 C READ (NBERTP) ALPH
20769 C READ (NBERTP) BET
20770 C READ (NBERTP) INWAPS
20771 C READ (NBERTP) WAPS
20772 C READ (NBERTP) T12NUC
20773 C READ (NBERTP) JSPNUC
20774 C READ (NBERTP) JPTNUC
20775 C READ (NBERTP) INWISM
20776 C READ (NBERTP) IZWISM
20777 C READ (NBERTP) WAPISM
20778 C READ (NBERTP) T12ISM
20779 C READ (NBERTP) JSPISM
20780 C READ (NBERTP) JPTISM
20781 C READ (NBERTP) APRIME
20782 C WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20783 C READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20784 C IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20785 C & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20787 C & ' *** Inconsistent Nuclear Geometry data on file ***'
20790 C READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20791 C & EKATAB, PFATAB, PFRTAB
20792 C READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20794 C READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20795 C & ZZPXSE, EMPXSE, XMPXSE
20796 * Data about Fermi-breakup:
20797 C READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20798 C IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20799 C & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20800 C WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20801 C & ' in the Nuclear Data file ***'
20802 C STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20804 C READ (NBERTP) IFRBKN
20805 C READ (NBERTP) IFRBKZ
20806 C READ (NBERTP) IFBKSP
20807 C READ (NBERTP) IFBKST
20808 C READ (NBERTP) EEXFBK
20809 C CLOSE (UNIT=NBERTP)
20811 SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20814 SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20817 IF ( ILVMOD .LE. 0 ) THEN
20823 DO 300 JZ = 1, IZCOOK
20824 CAM4 (JZ) = PZCOOK (JZ)
20826 DO 400 JN = 1, INCOOK
20827 CAM5 (JN) = PNCOOK (JZ)
20833 IF ( ILVMOD .EQ. 1 ) THEN
20835 & ' **** Standard EVAP T=0 level density used ****'
20836 ELSE IF ( ILVMOD .EQ. 2 ) THEN
20838 & ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20839 ELSE IF ( ILVMOD .EQ. 3 ) THEN
20841 & ' **** Julich A-dependent level density used ****'
20842 ELSE IF ( ILVMOD .EQ. 4 ) THEN
20844 & ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20848 & ' **** Unknown T=0 level density option requested ****'
20849 STOP 'BERTTP-ILVMOD'
20851 IF ( JLVMOD .LE. 0 ) THEN
20854 & ' **** No Excitation en. dependence for level densities ****'
20855 ELSE IF ( JLVMOD .EQ. 1 ) THEN
20857 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20859 & ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20865 ELSE IF ( JLVMOD .EQ. 2 ) THEN
20867 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20869 & ' **** with UNKNOWN set of parameters for T=oo ****'
20870 STOP 'BERTTP-JLVMOD'
20871 ELSE IF ( JLVMOD .EQ. 3 ) THEN
20873 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20875 & ' **** with UNKNOWN set of parameters for T=oo ****'
20876 STOP 'BERTTP-JLVMOD'
20877 ELSE IF ( JLVMOD .EQ. 4 ) THEN
20879 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20881 & ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20887 ELSE IF ( JLVMOD .EQ. 5 ) THEN
20889 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20891 & ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20896 ELSE IF ( JLVMOD .EQ. 6 ) THEN
20898 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20900 & ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20905 ELSE IF ( JLVMOD .EQ. 7 ) THEN
20907 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20909 & ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20914 ELSE IF ( JLVMOD .EQ. 8 ) THEN
20916 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20918 & ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20925 & ' **** Unknown T=oo level density option requested ****'
20926 STOP 'BERTTP-JLVMOD'
20930 & ' **** Cook''s modified pairing energy used ****'
20933 & ' **** Original Gilbert/Cameron pairing energy used ****'
20940 PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20943 PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20948 *$ CREATE DT_EVEVAP.FOR
20951 *====evevap============================================================*
20953 SUBROUTINE DT_EVEVAP(WE)
20955 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20957 PARAMETER ( LINP = 10 ,
20961 * flags for input different options
20962 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20963 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20964 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20971 *$ CREATE DT_FRBKIN.FOR
20974 *====frbkin============================================================*
20976 SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
20978 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20980 PARAMETER ( LINP = 10 ,
20984 LOGICAL LDUM1,LDUM2
20989 *$ CREATE DT_EXPLOD.FOR
20992 *=== explod ===========================================================*
20994 SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
20997 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21000 DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21001 & ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21006 ************************************************************************
21008 * DPMJET 3.0: cross section routines *
21010 ************************************************************************
21013 * SUBROUTINE DT_SHNDIF
21014 * diffractive cross sections (all energies)
21015 * SUBROUTINE DT_PHOXS
21016 * total and inel. cross sections from PHOJET interpol. tables
21017 * SUBROUTINE DT_XSHN
21018 * total and el. cross sections for all energies
21019 * SUBROUTINE DT_SIHNAB
21020 * pion 2-nucleon absorption cross sections
21021 * SUBROUTINE DT_SIGEMU
21022 * cross section for target "compounds"
21023 * SUBROUTINE DT_SIGGA
21024 * photon nucleus cross sections
21025 * SUBROUTINE DT_SIGGAT
21026 * photon nucleus cross sections from tables
21027 * SUBROUTINE DT_SANO
21028 * anomalous hard photon-nucleon cross sections from tables
21029 * SUBROUTINE DT_SIGGP
21030 * photon nucleon cross sections
21031 * SUBROUTINE DT_SIGVEL
21032 * quasi-elastic vector meson prod. cross sections
21033 * DOUBLE PRECISION FUNCTION DT_SIGVP
21035 * DOUBLE PRECISION FUNCTION DT_RRM2
21036 * DOUBLE PRECISION FUNCTION DT_RM2
21037 * DOUBLE PRECISION FUNCTION DT_SAM2
21038 * SUBROUTINE DT_CKMT
21039 * SUBROUTINE DT_CKMTX
21040 * SUBROUTINE DT_PDF0
21041 * SUBROUTINE DT_CKMTQ0
21042 * SUBROUTINE DT_CKMTDE
21043 * SUBROUTINE DT_CKMTPR
21044 * FUNCTION DT_CKMTFF
21046 * SUBROUTINE DT_FLUINI
21047 * total nucleon cross section fluctuation treatment
21049 * SUBROUTINE DT_SIGTBL
21050 * pre-tabulation of low-energy elastic x-sec. using SIHNEL
21051 * SUBROUTINE DT_XSTABL
21055 *$ CREATE DT_SHNDIF.FOR
21058 *===shndif===============================================================*
21060 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21062 **********************************************************************
21063 * Single diffractive hadron-nucleon cross sections *
21064 * S.Roesler 14/1/93 *
21066 * The cross sections are calculated from extrapolated single *
21067 * diffractive antiproton-proton cross sections (DTUJET92) using *
21068 * scaling relations between total and single diffractive cross *
21070 **********************************************************************
21072 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21074 PARAMETER (ZERO=0.0D0)
21076 * particle properties (BAMJET index convention)
21078 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21079 & IICH(210),IIBAR(210),K1(210),K2(210)
21081 CSD1 = 4.201483727D0
21082 CSD4 = -0.4763103556D-02
21083 CSD5 = 0.4324148297D0
21085 CHMSD1 = 0.8519297242D0
21086 CHMSD4 = -0.1443076599D-01
21087 CHMSD5 = 0.4014954567D0
21089 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21090 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21092 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21093 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21094 FRAC = SHMSD/SDIAPP
21096 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21097 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21098 & 10, 10, 20, 20, 20) KPROJ
21101 *---------------------------- p - p , n - p , sigma0+- - p ,
21103 CSD1 = 6.004476070D0
21104 CSD4 = -0.1257784606D-03
21105 CSD5 = 0.2447335720D0
21106 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21107 SIGDIH = FRAC*SIGDIF
21114 C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21116 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21119 C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21120 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21122 SIGDIH = FRAC*SIGDIF
21126 *-------------------------- leptons..
21132 *$ CREATE DT_PHOXS.FOR
21135 *===phoxs================================================================*
21137 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21139 ************************************************************************
21140 * Total/inelastic proton-nucleon cross sections taken from PHOJET- *
21141 * interpolation tables. *
21142 * This version dated 05.11.97 is written by S. Roesler *
21143 ************************************************************************
21145 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21148 PARAMETER ( LINP = 10 ,
21151 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21152 PARAMETER (TWOPI = 6.283185307179586454D+00,
21154 & GEV2MB = 0.38938D0)
21157 DATA LFIRST /.TRUE./
21159 * nucleon-nucleon event-generator
21162 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21163 * particle properties (BAMJET index convention)
21165 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21166 & IICH(210),IIBAR(210),K1(210),K2(210)
21169 C PARAMETER (IEETAB=10)
21170 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21172 C energy-interpolation table
21174 PARAMETER ( IEETA2 = 20 )
21176 DOUBLE PRECISION SIGTAB,SIGECM
21177 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21180 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21181 WRITE(LOUT,*) MCGENE
21182 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21186 IF (ECM.LE.ZERO) THEN
21187 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21188 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21191 IF (MODE.EQ.1) THEN
21196 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21198 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
21199 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21205 IF(ECM.LE.SIGECM(IP,1)) THEN
21208 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21210 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21217 WRITE(LOUT,'(/1X,A,2E12.3)')
21218 & 'PHOXS: warning! energy above initialization limit (',
21219 & ECM,SIGECM(IP,ISIMAX)
21226 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21227 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21229 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21230 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21231 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21232 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21233 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21239 *$ CREATE DT_XSHN.FOR
21242 *===xshn===============================================================*
21244 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21246 ************************************************************************
21247 * Total and elastic hadron-nucleon cross section. *
21248 * Below 500GeV cross sections are based on the '98 data compilation *
21249 * of the PDG. At higher energies PHOJET results are used (patched to *
21250 * the low energy data at 500GeV). *
21251 * IP projectile index (BAMJET numbering scheme) *
21252 * (should be in the range 1..25) *
21253 * IT target index (BAMJET numbering scheme) *
21254 * (1 = proton, 8 = neutron) *
21255 * PL laboratory momentum *
21256 * ECM cm. energy (ignored if PL>0) *
21257 * STOT total cross section *
21258 * SELA elastic cross section *
21259 * Last change: 24.4.99 by S. Roesler *
21260 ************************************************************************
21262 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21265 PARAMETER ( LINP = 10 ,
21268 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21270 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21271 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21272 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21275 * particle properties (BAMJET index convention)
21277 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21278 & IICH(210),IIBAR(210),K1(210),K2(210)
21279 * nucleon-nucleon event-generator
21282 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21284 C PARAMETER (IEETAB=10)
21285 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21287 C energy-interpolation table
21289 PARAMETER ( IEETA2 = 20 )
21291 DOUBLE PRECISION SIGTAB,SIGECM
21292 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21294 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21295 DIMENSION IDXDAT(25,2)
21298 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21299 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21300 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21301 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21302 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21303 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21304 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21306 * total cross sections:
21308 DATA (ASIGTO(1,K),K=1,NPOINT) /
21309 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21310 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21311 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21312 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21313 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21314 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21315 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21317 DATA (ASIGTO(2,K),K=1,NPOINT) /
21318 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21319 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21320 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21321 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21322 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21323 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21324 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21326 DATA (ASIGTO(3,K),K=1,NPOINT) /
21327 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21328 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21329 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21330 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21331 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21332 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21333 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21335 DATA (ASIGTO(4,K),K=1,NPOINT) /
21336 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21337 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21338 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21339 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21340 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21341 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21342 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21344 DATA (ASIGTO(5,K),K=1,NPOINT) /
21345 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21346 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21347 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21348 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21349 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21350 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21351 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21353 DATA (ASIGTO(6,K),K=1,NPOINT) /
21354 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21355 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21356 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21357 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21358 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21359 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21360 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21362 DATA (ASIGTO(7,K),K=1,NPOINT) /
21363 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21364 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21365 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21366 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21367 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21368 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21369 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21371 DATA (ASIGTO(8,K),K=1,NPOINT) /
21372 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21373 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21374 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21375 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21376 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21377 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21378 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21380 DATA (ASIGTO(9,K),K=1,NPOINT) /
21381 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21382 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21383 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21384 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21385 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21386 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21387 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21389 DATA (ASIGTO(10,K),K=1,NPOINT) /
21390 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21391 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21392 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21393 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21394 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21395 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21396 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21398 * elastic cross sections:
21400 DATA (ASIGEL(1,K),K=1,NPOINT) /
21401 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21402 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21403 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21404 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21405 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21406 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21407 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21409 DATA (ASIGEL(2,K),K=1,NPOINT) /
21410 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21411 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21412 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21413 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21414 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21415 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21416 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21418 DATA (ASIGEL(3,K),K=1,NPOINT) /
21419 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21420 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21421 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21422 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21423 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21424 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21425 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21427 DATA (ASIGEL(4,K),K=1,NPOINT) /
21428 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21429 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21430 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21431 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21432 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21433 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21434 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21436 DATA (ASIGEL(5,K),K=1,NPOINT) /
21437 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21438 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21439 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21440 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21441 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21442 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21443 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21445 DATA (ASIGEL(6,K),K=1,NPOINT) /
21446 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21447 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21448 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21449 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21450 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21451 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21452 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21454 DATA (ASIGEL(7,K),K=1,NPOINT) /
21455 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21456 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21457 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21458 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21459 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21460 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21461 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21463 DATA (ASIGEL(8,K),K=1,NPOINT) /
21464 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21465 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21466 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21467 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21468 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21469 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21470 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21472 DATA (ASIGEL(9,K),K=1,NPOINT) /
21473 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21474 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21475 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21476 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21477 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21478 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21479 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21481 DATA (ASIGEL(10,K),K=1,NPOINT) /
21482 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21483 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21484 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21485 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21486 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21487 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21488 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21490 DATA (IDXDAT(K,1),K=1,25) /
21491 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21493 DATA (IDXDAT(K,2),K=1,25) /
21494 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21497 DATA LFIRST /.TRUE./
21500 APLABL = LOG10(PLABLO)
21501 APLABH = LOG10(PLABHI)
21502 APTHRE = LOG10(PTHRE)
21503 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21504 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21507 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21508 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21509 IF (MCGENE.EQ.2) THEN
21510 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21511 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21513 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21516 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21518 PHOSEL = PHOSTO-PHOSIN
21519 APHOST = LOG10(PHOSTO)
21520 APHOSE = LOG10(PHOSEL)
21527 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21528 WRITE(LOUT,1000) IP,IT
21529 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21530 & 'proj/target',2I4)
21534 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21535 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21536 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21537 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21538 WRITE(LOUT,1001) PLAB,ECMS
21539 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21543 * index of spectrum
21546 IF (AAM(IP).GT.ZERO) THEN
21547 IF (ABS(IIBAR(IP)).GT.0) THEN
21557 IF (IT.EQ.8) IDXT = 2
21558 IDXS = IDXDAT(IDXP,IDXT)
21559 IF (IDXS.EQ.0) RETURN
21561 * compute momentum bin indices
21562 IF (PLAB.LT.PLABLO) THEN
21565 ELSEIF (PLAB.GE.PLABHI) THEN
21569 APLAB = LOG10(PLAB)
21570 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21571 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21572 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21573 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21578 * interpolate cross section
21579 IF (IDXS.GT.10) THEN
21581 IDXS2 = IDXS-10*IDXS1
21582 IF (IDX0.EQ.IDX1) THEN
21583 IF (IDX0.EQ.1) THEN
21584 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21585 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21588 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21589 PHOSEL = PHOSTO-PHOSIN
21590 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21591 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21592 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21593 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21594 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21595 ASELA = 0.5D0*(ASELA1+ASELA2)
21598 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21599 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21600 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21601 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21602 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21603 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21604 ASELA1 = ASIGEL(IDXS1,IDX0)+
21605 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21606 ASELA2 = ASIGEL(IDXS2,IDX0)+
21607 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21608 ASELA = 0.5D0*(ASELA1+ASELA2)
21611 IF (IDX0.EQ.IDX1) THEN
21612 IF (IDX0.EQ.1) THEN
21613 ASTOT = ASIGTO(IDXS,IDX0)
21614 ASELA = ASIGEL(IDXS,IDX0)
21617 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21618 PHOSEL = PHOSTO-PHOSIN
21619 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21620 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21623 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21624 ASTOT = ASIGTO(IDXS,IDX0)+
21625 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21626 ASELA = ASIGEL(IDXS,IDX0)+
21627 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21630 STOT = 10.0D0**ASTOT
21631 SELA = 10.0D0**ASELA
21636 *$ CREATE DT_SIHNAB.FOR
21639 *===sihnab===============================================================*
21641 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21643 **********************************************************************
21644 * Pion 2-nucleon absorption cross sections. *
21645 * (sigma_tot for pi+ d --> p p, pi- d --> n n *
21646 * taken from Ritchie PRC 28 (1983) 926 ) *
21647 * This version dated 18.05.96 is written by S. Roesler *
21648 **********************************************************************
21650 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21652 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21653 PARAMETER (AMPR = 938.0D0,
21663 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21664 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21666 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21667 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21668 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21669 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21670 * approximate 3N-abs., I=1-abs. etc.
21671 SIGABS = SIGABS/0.40D0
21672 * pi0-absorption (rough approximation!!)
21673 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21678 *$ CREATE DT_SIGEMU.FOR
21681 *===sigemu=============================================================*
21683 SUBROUTINE DT_SIGEMU
21685 ************************************************************************
21686 * Combined cross section for target compounds. *
21687 * This version dated 6.4.98 is written by S. Roesler *
21688 ************************************************************************
21690 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21692 PARAMETER ( LINP = 10 ,
21695 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21696 & OHALF=0.5D0,ONE=1.0D0)
21698 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21699 * Glauber formalism: cross sections
21700 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21701 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21702 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21703 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21704 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21705 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21706 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21707 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21708 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21709 & BSLOPE,NEBINI,NQBINI
21710 * emulsion treatment
21711 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21713 * nucleon-nucleon event-generator
21716 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21718 IF (MCGENE.NE.4) THEN
21719 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21720 WRITE(LOUT,'(15X,A)') '-----------------------'
21740 IF (NCOMPO.GT.0) THEN
21742 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21743 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21744 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21745 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21746 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21747 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21748 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21749 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21750 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21751 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21752 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21753 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21754 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21755 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21756 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21757 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21759 ERRTOT = SQRT(ERRTOT)
21760 ERRELA = SQRT(ERRELA)
21761 ERRQEP = SQRT(ERRQEP)
21762 ERRQET = SQRT(ERRQET)
21763 ERRQE2 = SQRT(ERRQE2)
21764 ERRPRO = SQRT(ERRPRO)
21765 ERRDEL = SQRT(ERRDEL)
21766 ERRDQE = SQRT(ERRDQE)
21768 SIGTOT = XSTOT(IE,IQ,1)
21769 SIGELA = XSELA(IE,IQ,1)
21770 SIGQEP = XSQEP(IE,IQ,1)
21771 SIGQET = XSQET(IE,IQ,1)
21772 SIGQE2 = XSQE2(IE,IQ,1)
21773 SIGPRO = XSPRO(IE,IQ,1)
21774 SIGDEL = XSDEL(IE,IQ,1)
21775 SIGDQE = XSDQE(IE,IQ,1)
21776 ERRTOT = XETOT(IE,IQ,1)
21777 ERRELA = XEELA(IE,IQ,1)
21778 ERRQEP = XEQEP(IE,IQ,1)
21779 ERRQET = XEQET(IE,IQ,1)
21780 ERRQE2 = XEQE2(IE,IQ,1)
21781 ERRPRO = XEPRO(IE,IQ,1)
21782 ERRDEL = XEDEL(IE,IQ,1)
21783 ERRDQE = XEDQE(IE,IQ,1)
21785 IF (MCGENE.NE.4) THEN
21786 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21787 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21788 WRITE(LOUT,1001) SIGTOT,ERRTOT
21789 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21790 WRITE(LOUT,1002) SIGELA,ERRELA
21791 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21792 WRITE(LOUT,1003) SIGQEP,ERRQEP
21793 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21795 WRITE(LOUT,1004) SIGQET,ERRQET
21796 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21798 WRITE(LOUT,1005) SIGQE2,ERRQE2
21799 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21800 & ' +-',F11.5,' mb')
21801 WRITE(LOUT,1006) SIGPRO,ERRPRO
21802 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21803 WRITE(LOUT,1007) SIGDEL,ERRDEL
21804 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21805 WRITE(LOUT,1008) SIGDQE,ERRDQE
21806 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21815 *$ CREATE DT_SIGGA.FOR
21818 *===sigga==============================================================*
21820 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21822 ************************************************************************
21823 * Total/inelastic photon-nucleus cross sections. *
21824 * !!!! Overwrites SHMAKI-initialization. Do not use it during *
21825 * production runs !!!! *
21826 * This version dated 27.03.96 is written by S. Roesler *
21827 ************************************************************************
21829 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21831 PARAMETER ( LINP = 10 ,
21834 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21835 & OHALF=0.5D0,ONE=1.0D0)
21836 PARAMETER (AMPROT = 0.938D0)
21838 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21839 * Glauber formalism: cross sections
21840 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21841 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21842 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21843 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21844 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21845 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21846 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21847 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21848 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21849 & BSLOPE,NEBINI,NQBINI
21856 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21857 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21858 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21859 STOT = XSTOT(1,1,1)
21860 ETOT = XETOT(1,1,1)
21867 *$ CREATE DT_SIGGAT.FOR
21870 *===siggat=============================================================*
21872 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21874 ************************************************************************
21875 * Total/inelastic photon-nucleus cross sections. *
21876 * Uses pre-tabulated cross section. *
21877 * This version dated 29.07.96 is written by S. Roesler *
21878 ************************************************************************
21880 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21882 PARAMETER ( LINP = 10 ,
21885 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21886 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21888 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21889 * Glauber formalism: cross sections
21890 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21891 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21892 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21893 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21894 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21895 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21896 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21897 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21898 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21899 & BSLOPE,NEBINI,NQBINI
21905 IF (NEBINI.GT.1) THEN
21906 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21910 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21912 IF (ECMI.LT.ECMNN(I)) THEN
21915 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21925 IF (NQBINI.GT.1) THEN
21926 IF (Q2I.GE.Q2G(NQBINI)) THEN
21930 ELSEIF (Q2I.GT.Q2G(1)) THEN
21932 IF (Q2I.LT.Q2G(I)) THEN
21935 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21936 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21937 C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21945 STOT = XSTOT(I1,J1,NTARG)+
21946 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21947 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21948 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21949 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21954 *$ CREATE DT_SANO.FOR
21957 *===sigano=============================================================*
21959 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21961 ************************************************************************
21962 * This version dated 31.07.96 is written by S. Roesler *
21963 ************************************************************************
21965 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21967 PARAMETER ( LINP = 10 ,
21970 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21971 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21974 * VDM parameter for photon-nucleus interactions
21975 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21976 * properties of interacting particles
21977 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21979 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21981 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21982 & 0.100D+04,0.200D+04,0.500D+04
21984 * fixed cut (3 GeV/c)
21986 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21987 & 0.062D+00,0.054D+00,0.042D+00
21990 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21991 & 3.3086D-01,7.6255D-01,2.1319D+00
21993 * running cut (based on obsolete Phojet-caluclations, bugs..)
21995 C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21996 C & 0.167E+00,0.150E+00,0.131E+00
21999 C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22000 C & 2.5736E-01,4.5593E-01,8.2550E-01
22004 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22008 IF (ECM.GE.ECMANO(NE)) THEN
22011 ELSEIF (ECM.GT.ECMANO(1)) THEN
22013 IF (ECM.LT.ECMANO(IE)) THEN
22016 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22022 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22023 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22024 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22025 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22031 *$ CREATE DT_SIGGP.FOR
22034 *===siggp==============================================================*
22036 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22038 ************************************************************************
22039 * Total/inelastic photon-nucleon cross sections. *
22040 * This version dated 30.04.96 is written by S. Roesler *
22041 ************************************************************************
22043 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22045 PARAMETER ( LINP = 10 ,
22048 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22049 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22051 & GEV2MB = 0.38938D0,
22052 & ALPHEM = ONE/137.0D0)
22054 * particle properties (BAMJET index convention)
22056 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22057 & IICH(210),IIBAR(210),K1(210),K2(210)
22058 * VDM parameter for photon-nucleus interactions
22059 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22062 C CHARACTER*8 MDLNA
22063 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22064 C PARAMETER (IEETAB=10)
22065 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22067 C model switches and parameters
22069 INTEGER ISWMDL,IPAMDL
22070 DOUBLE PRECISION PARMDL
22071 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22072 C energy-interpolation table
22074 PARAMETER ( IEETA2 = 20 )
22076 DOUBLE PRECISION SIGTAB,SIGECM
22077 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22080 C PARAMETER (NPOINT=80)
22081 PARAMETER (NPOINT=16)
22082 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22089 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22090 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22094 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22096 X = Q2/(W2+Q2-AAM(1)**2)
22098 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22099 X = Q2/(W2+Q2-AAM(1)**2)
22100 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22101 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22102 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22103 W2 = Q2*(ONE-X)/X+AAM(1)**2
22105 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22110 IF (MODEGA.EQ.1) THEN
22112 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22115 C ALLMF2 = PHO_ALLM97(Q2,W)
22116 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22117 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22120 ELSEIF (MODEGA.EQ.2) THEN
22121 IF (INTRGE(1).EQ.1) THEN
22122 AMLO2 = (3.0D0*AAM(13))**2
22123 ELSEIF (INTRGE(1).EQ.2) THEN
22128 IF (INTRGE(2).EQ.1) THEN
22130 ELSEIF (INTRGE(2).EQ.2) THEN
22135 AMHI20 = (ECM-AAM(1))**2
22136 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22137 XAMLO = LOG( AMLO2+Q2 )
22138 XAMHI = LOG( AMHI2+Q2 )
22140 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22142 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22146 AM2 = EXP(ABSZX(J))-Q2
22147 IF (AM2.LT.16.0D0) THEN
22149 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22154 C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22155 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22156 & * (ONE+EPSPOL*Q2/AM2)
22157 SUM = SUM+WEIGHT(J)*FAC
22160 SDIR = DT_SIGVP(X,Q2)
22161 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22162 SDIR = SDIR/(0.588D0+RL2+Q2)
22163 C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22164 ELSEIF (MODEGA.EQ.3) THEN
22165 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22166 ELSEIF (MODEGA.EQ.4) THEN
22167 * load cross sections from PHOJET interpolation table
22169 IF(ECM.LE.SIGECM(IP,1)) THEN
22172 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22174 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22180 WRITE(LOUT,'(/1X,A,2E12.3)')
22181 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22186 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22187 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22189 * cross section dependence on photon virtuality
22192 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22193 & /(1.D0+Q2/PARMDL(30+I))**2
22195 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22199 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22200 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22201 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22205 SDIR = SDIR/(FSUP1*FSUP2)
22214 *$ CREATE DT_SIGVEL.FOR
22217 *===sigvel=============================================================*
22219 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22221 ************************************************************************
22222 * Cross section for elastic vector meson production *
22223 * This version dated 10.05.96 is written by S. Roesler *
22224 ************************************************************************
22226 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22228 PARAMETER ( LINP = 10 ,
22231 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22232 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22234 & GEV2MB = 0.38938D0,
22235 & ALPHEM = ONE/137.0D0)
22237 * particle properties (BAMJET index convention)
22239 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22240 & IICH(210),IIBAR(210),K1(210),K2(210)
22241 * VDM parameter for photon-nucleus interactions
22242 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22245 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22246 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22250 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22252 X = Q2/(W2+Q2-AAM(1)**2)
22254 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22255 X = Q2/(W2+Q2-AAM(1)**2)
22256 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22257 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22258 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22259 W2 = Q2*(ONE-X)/X+AAM(1)**2
22261 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22269 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22270 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22272 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22273 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22275 IF (IDXV.EQ.33) THEN
22280 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22282 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
22283 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
22288 *$ CREATE DT_SIGVP.FOR
22291 *===sigvp==============================================================*
22293 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22295 ************************************************************************
22297 ************************************************************************
22299 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22302 PARAMETER ( LINP = 10 ,
22305 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22306 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22308 & GEV2MB = 0.38938D0,
22309 & AMPROT = 0.938D0,
22310 & ALPHEM = ONE/137.0D0)
22311 * VDM parameter for photon-nucleus interactions
22312 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22316 IF (XI.LE.ZERO) X = 0.0001D0
22317 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22319 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22322 IF (MODEGA.EQ.1) THEN
22323 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22326 C ALLMF2 = PHO_ALLM97(Q2,W)
22327 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22328 C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22329 C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22330 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22331 ELSEIF (MODEGA.EQ.4) THEN
22332 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22333 C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22334 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22336 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22343 *$ CREATE DT_RRM2.FOR
22346 *===RRM2===============================================================*
22348 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22350 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22352 PARAMETER ( LINP = 10 ,
22355 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22356 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22358 & GEV2MB = 0.38938D0)
22360 * particle properties (BAMJET index convention)
22362 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22363 & IICH(210),IIBAR(210),K1(210),K2(210)
22364 * VDM parameter for photon-nucleus interactions
22365 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22367 S = Q2*(ONE-X)/X+AAM(1)**2
22370 IF (INTRGE(1).EQ.1) THEN
22371 AMLO2 = (3.0D0*AAM(13))**2
22372 ELSEIF (INTRGE(1).EQ.2) THEN
22377 IF (INTRGE(2).EQ.1) THEN
22379 ELSEIF (INTRGE(2).EQ.2) THEN
22384 AMHI20 = (ECM-AAM(1))**2
22385 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22389 IF (AMHI2.LE.AM1C2) THEN
22390 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22391 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22392 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22393 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22395 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22396 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22397 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22403 *$ CREATE DT_RM2.FOR
22406 *===RM2================================================================*
22408 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22410 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22412 PARAMETER ( LINP = 10 ,
22415 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22416 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22418 & GEV2MB = 0.38938D0)
22419 * VDM parameter for photon-nucleus interactions
22420 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22422 IF (RL2.LE.ZERO) THEN
22423 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22424 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22425 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22427 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22428 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22429 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22430 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22432 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22433 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22439 *$ CREATE DT_SAM2.FOR
22442 *===SAM2===============================================================*
22444 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22446 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22448 PARAMETER ( LINP = 10 ,
22451 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22452 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22453 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22455 & GEV2MB = 0.38938D0)
22457 * particle properties (BAMJET index convention)
22459 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22460 & IICH(210),IIBAR(210),K1(210),K2(210)
22461 * VDM parameter for photon-nucleus interactions
22462 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22465 IF (INTRGE(1).EQ.1) THEN
22466 AMLO2 = (3.0D0*AAM(13))**2
22467 ELSEIF (INTRGE(1).EQ.2) THEN
22472 IF (INTRGE(2).EQ.1) THEN
22474 ELSEIF (INTRGE(2).EQ.2) THEN
22479 AMHI20 = (ECM-AAM(1))**2
22480 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22484 YLO = LOG(AMLO2+Q2)
22485 YC1 = LOG(AM1C2+Q2)
22486 YC2 = LOG(AM2C2+Q2)
22487 YHI = LOG(AMHI2+Q2)
22488 IF (AMHI2.LE.AM1C2) THEN
22490 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22497 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22498 IF (YSAM2.LE.YC1) THEN
22500 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22505 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22506 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22507 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22509 DT_SAM2 = EXP(YSAM2)-Q2
22514 *$ CREATE DT_CKMT.FOR
22517 *===ckmt===============================================================*
22519 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22522 ************************************************************************
22523 * This version dated 31.01.96 is written by S. Roesler *
22524 ************************************************************************
22526 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22528 PARAMETER ( LINP = 10 ,
22531 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22533 PARAMETER (Q02 = 2.0D0,
22537 DIMENSION PD(-6:6),SEA(3),VAL(2)
22539 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22540 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22541 ADQ2 = LOG10(Q12)-LOG10(Q02)
22542 F2P = (F2Q1-F2Q0)/ADQ2
22543 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22544 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22545 F2PP = (F2PQ1-F2PQ0)/ADQ2
22546 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22548 Q2 = MAX(SCALE**2.0D0,TINY10)
22549 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22550 IF (Q2.LT.Q02) THEN
22551 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22562 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22575 C USEA = USEA*SMOOTH
22576 C DSEA = DSEA*SMOOTH
22586 *$ CREATE DT_CKMTX.FOR
22588 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22589 C**********************************************************************
22591 C PDF based on Regge theory, evolved with .... by ....
22593 C input: IPAR 2212 proton (not installed)
22597 C output: PD(-6:6) x*f(x) parton distribution functions
22598 C (PDFLIB convention: d = PD(1), u = PD(2) )
22600 C**********************************************************************
22603 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22604 PARAMETER ( LINP = 10 ,
22612 C QCD lambda for evolution
22615 C Q0**2 for evolution
22619 C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22620 C q(6)=x*charm, q(7)=x*gluon
22624 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22626 IF(IPAR.EQ.2212) THEN
22627 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22628 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22629 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22630 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22631 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22632 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22633 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22634 C ELSEIF (IPAR.EQ.45) THEN
22635 C CALL CKMTPO(1,0,XX,SB,QQ(1))
22636 C CALL CKMTPO(2,0,XX,SB,QQ(2))
22637 C CALL CKMTPO(3,0,XX,SB,QQ(3))
22638 C CALL CKMTPO(4,0,XX,SB,QQ(4))
22639 C CALL CKMTPO(5,0,XX,SB,QQ(5))
22640 C CALL CKMTPO(8,0,XX,SB,QQ(6))
22641 C CALL CKMTPO(7,0,XX,SB,QQ(7))
22642 ELSEIF (IPAR.EQ.100) THEN
22643 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22644 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22645 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22646 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22647 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22648 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22649 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22651 WRITE(LOUT,'(1X,A,I4,A)')
22652 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22658 PD(-4) = DBLE(QQ(6))
22659 PD(-3) = DBLE(QQ(3))
22660 PD(-2) = DBLE(QQ(4))
22661 PD(-1) = DBLE(QQ(5))
22662 PD(0) = DBLE(QQ(7))
22663 PD(1) = DBLE(QQ(2))
22664 PD(2) = DBLE(QQ(1))
22665 PD(3) = DBLE(QQ(3))
22666 PD(4) = DBLE(QQ(6))
22669 IF(IPAR.EQ.45) THEN
22670 CDN = (PD(1)-PD(-1))/2.D0
22671 CUP = (PD(2)-PD(-2))/2.D0
22672 PD(-1) = PD(-1) + CDN
22673 PD(-2) = PD(-2) + CUP
22677 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22678 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22679 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22683 *$ CREATE DT_PDF0.FOR
22686 *===pdf0===============================================================*
22688 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22690 ************************************************************************
22691 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22692 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22693 * IPAR = 2212 proton *
22695 * This version dated 31.01.96 is written by S. Roesler *
22696 ************************************************************************
22698 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22700 PARAMETER ( LINP = 10 ,
22703 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22712 & DELTA0 = 0.07684D0,
22717 & ALPHAR = 0.415D0,
22721 PARAMETER (NPOINT=16)
22722 C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22723 DIMENSION SEA(3),VAL(2)
22725 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22726 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22728 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22729 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22730 SEA(1) = 0.75D0*SEA0
22733 VAL(1) = 9.0D0/4.0D0*VALU0
22734 VAL(2) = 9.0D0*VALD0
22735 GLU0 = SEA(1)/(1.0D0-X)
22736 F2 = SEA0+VALU0+VALD0
22737 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22738 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22739 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22740 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22741 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22745 C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22747 C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22752 C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22753 C VALU0 = 9.0D0/4.0D0*VALU0
22754 C VALD0 = 9.0D0*VALD0
22755 C SEA0 = 0.75D0*SEA0
22756 C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22757 C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22759 C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22761 WRITE(LOUT,'(1X,A,I4,A)')
22762 & 'PDF0: IPAR =',IPAR,' not implemented!'
22769 *$ CREATE DT_CKMTQ0.FOR
22772 *===ckmtq0=============================================================*
22774 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22776 ************************************************************************
22777 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22778 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22779 * IPAR = 2212 proton *
22781 * This version dated 31.01.96 is written by S. Roesler *
22782 ************************************************************************
22784 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22786 PARAMETER ( LINP = 10 ,
22789 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22798 & DELTA0 = 0.07684D0,
22803 & ALPHAR = 0.415D0,
22807 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22808 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22810 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22811 IF (IPAR.EQ.2212) THEN
22818 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22819 & (Q2/(Q2+A))**(1.0D0+DELTA)
22820 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22821 & (Q2/(Q2+B))**(ALPHAR)
22822 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22823 & (Q2/(Q2+B))**(ALPHAR)
22825 WRITE(LOUT,'(1X,A,I4,A)')
22826 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22834 *$ CREATE DT_CKMTDE.FOR
22836 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22838 C**********************************************************************
22840 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22842 C This version by S. Roesler, 30.01.96
22843 C**********************************************************************
22846 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22847 EQUIVALENCE (GF(1,1,1),DL(1))
22850 DATA (DL(K),K= 1, 85) /
22851 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22852 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22853 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22854 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22855 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22856 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22857 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22858 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22859 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22860 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22861 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22862 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22863 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22864 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22865 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22866 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22867 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22868 DATA (DL(K),K= 86, 170) /
22869 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22870 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22871 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22872 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22873 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22874 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22875 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22876 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22877 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22878 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22879 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22880 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22881 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22882 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22883 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22884 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22885 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22886 DATA (DL(K),K= 171, 255) /
22887 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22888 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22889 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22890 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22891 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22892 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22893 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22894 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22895 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22896 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22897 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22898 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22899 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22900 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22901 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22902 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22903 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22904 DATA (DL(K),K= 256, 340) /
22905 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22906 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22907 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22908 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22909 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22910 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22911 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22912 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22913 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22914 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22915 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22916 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22917 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22918 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22919 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22920 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22921 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22922 DATA (DL(K),K= 341, 425) /
22923 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22924 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22925 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22926 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22927 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22928 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22929 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22930 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22931 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22932 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22933 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22934 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22935 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22936 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22937 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22938 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22939 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22940 DATA (DL(K),K= 426, 510) /
22941 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22942 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22943 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22944 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22945 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22946 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22947 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22948 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22949 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22950 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22951 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22952 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22953 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22954 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22955 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22956 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22957 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22958 DATA (DL(K),K= 511, 595) /
22959 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22960 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22961 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22962 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22963 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22964 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22965 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22966 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22967 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22968 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22969 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22970 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22971 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22972 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22973 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22974 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22975 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22976 DATA (DL(K),K= 596, 680) /
22977 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22978 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22979 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22980 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22981 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22982 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22983 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22984 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22985 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22986 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22987 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22988 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22989 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22990 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22991 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22992 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22993 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22994 DATA (DL(K),K= 681, 765) /
22995 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22996 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22997 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22998 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22999 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23000 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23001 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23002 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23003 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23004 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23005 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23006 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23007 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23008 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23009 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23010 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23011 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23012 DATA (DL(K),K= 766, 850) /
23013 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23014 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23015 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23016 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23017 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23018 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23020 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23021 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23022 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23023 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23024 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23025 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23026 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23027 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23028 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23029 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23030 DATA (DL(K),K= 851, 935) /
23031 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23032 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23033 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23034 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23035 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23036 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23037 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23038 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23039 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23040 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23041 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23042 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23043 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23044 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23048 DATA (DL(K),K= 936, 1020) /
23049 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23050 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23051 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23052 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23053 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23054 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23055 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23056 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23057 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23058 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23059 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23060 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23061 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23062 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23063 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23064 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23065 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23066 DATA (DL(K),K= 1021, 1105) /
23067 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23068 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23069 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23070 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23071 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23072 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23073 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23074 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23075 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23076 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23077 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23078 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23082 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23083 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23084 DATA (DL(K),K= 1106, 1190) /
23085 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23086 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23087 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23088 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23089 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23090 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23091 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23092 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23093 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23094 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23095 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23096 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23097 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23098 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23099 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23100 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23101 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23102 DATA (DL(K),K= 1191, 1275) /
23103 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23104 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23105 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23106 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23107 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23108 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23109 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23110 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23111 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23112 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
23113 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23114 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23115 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23116 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23117 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23118 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23119 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23120 DATA (DL(K),K= 1276, 1360) /
23121 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23122 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23123 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23124 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23125 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23126 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23127 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23128 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23129 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23130 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23131 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23132 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23133 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23134 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23135 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23136 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23137 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23138 DATA (DL(K),K= 1361, 1445) /
23139 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23140 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23141 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23142 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23143 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23144 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23145 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23146 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
23147 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23148 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23149 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23150 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23151 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23152 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23153 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23154 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23155 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23156 DATA (DL(K),K= 1446, 1530) /
23157 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23158 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23159 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23160 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23161 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23162 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23163 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23164 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23165 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23166 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23167 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23168 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23169 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23170 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23171 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23172 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23173 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23174 DATA (DL(K),K= 1531, 1615) /
23175 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23176 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23177 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23178 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23179 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23180 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
23181 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23182 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23183 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23184 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23185 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23186 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23187 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23188 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23189 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23190 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23191 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23192 DATA (DL(K),K= 1616, 1700) /
23193 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23194 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23195 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23196 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23197 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23198 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23199 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23200 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23201 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23202 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23203 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23204 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23205 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23206 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23207 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23208 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23209 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23210 DATA (DL(K),K= 1701, 1785) /
23211 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23212 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23213 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23214 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
23215 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23216 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23217 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23218 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23219 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23220 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23221 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23222 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23223 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23224 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23225 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23226 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23227 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23228 DATA (DL(K),K= 1786, 1870) /
23229 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23230 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23231 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23232 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23233 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23234 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23235 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23236 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23237 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23238 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23239 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23240 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23241 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23242 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23243 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23244 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23245 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23246 DATA (DL(K),K= 1871, 1955) /
23247 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23248 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
23249 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23250 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23251 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23252 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23253 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23254 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23255 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23256 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23257 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23258 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23259 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23260 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23261 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23262 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23263 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23264 DATA (DL(K),K= 1956, 2040) /
23265 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23266 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23267 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23268 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23269 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23270 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23271 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23272 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23273 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23274 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23275 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23276 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23277 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23278 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23279 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23280 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23281 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23282 DATA (DL(K),K= 2041, 2125) /
23283 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23284 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23285 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23286 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23287 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23288 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23289 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23290 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23291 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23292 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23293 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23294 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23295 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23296 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23297 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23298 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23299 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23300 DATA (DL(K),K= 2126, 2210) /
23301 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23302 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23303 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23304 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23305 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23306 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23307 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23308 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23309 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23310 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23311 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23312 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23313 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23314 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23315 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
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 DATA (DL(K),K= 2211, 2295) /
23319 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23320 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23321 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23322 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23323 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23324 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23325 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23326 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23327 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23328 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23329 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23330 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23331 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23332 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23333 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23334 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23335 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23336 DATA (DL(K),K= 2296, 2380) /
23337 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23338 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23339 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23340 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23341 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23342 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23343 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23344 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23345 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23346 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23347 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23348 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23349 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23353 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23354 DATA (DL(K),K= 2381, 2465) /
23355 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23356 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23357 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23358 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23359 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23360 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23361 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23362 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23363 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23364 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23365 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23366 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23367 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23368 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23369 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23370 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23371 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23372 DATA (DL(K),K= 2466, 2550) /
23373 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23374 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23375 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23376 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23377 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23378 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23379 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23380 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23381 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23382 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23383 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23387 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23388 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23389 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23390 DATA (DL(K),K= 2551, 2635) /
23391 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23392 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23393 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23394 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23395 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23396 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23397 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23398 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23399 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23400 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23401 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23402 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23403 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23404 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23405 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23406 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23407 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23408 DATA (DL(K),K= 2636, 2720) /
23409 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23410 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23411 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23412 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23413 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23414 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23415 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23416 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23417 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23421 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23422 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23423 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23424 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23425 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23426 DATA (DL(K),K= 2721, 2805) /
23427 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23428 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23429 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23430 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23431 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23432 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23433 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23434 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23435 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23436 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23437 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23438 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23439 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23440 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23441 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23442 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23443 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23444 DATA (DL(K),K= 2806, 2890) /
23445 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23446 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23447 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23448 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23449 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23450 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23451 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23452 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23453 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23454 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23455 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23456 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23457 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23458 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23459 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23460 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23461 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23462 DATA (DL(K),K= 2891, 2975) /
23463 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23464 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23465 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23466 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23467 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23468 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23469 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23470 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23471 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23472 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23473 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23474 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23475 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23476 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23477 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23478 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23479 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23480 DATA (DL(K),K= 2976, 3060) /
23481 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23482 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23483 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23484 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23485 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23486 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23487 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23488 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23489 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23490 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23491 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23492 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23493 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23494 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23495 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23496 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23497 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23498 DATA (DL(K),K= 3061, 3145) /
23499 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23500 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23501 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23502 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23503 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23504 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23505 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23506 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23507 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23508 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23509 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23510 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23511 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23512 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23513 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23514 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23515 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23516 DATA (DL(K),K= 3146, 3230) /
23517 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23518 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23519 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23520 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23521 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23522 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23523 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23524 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23525 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23526 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23527 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23528 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23529 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23530 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23531 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23532 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23533 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23534 DATA (DL(K),K= 3231, 3315) /
23535 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23536 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23537 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23538 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23539 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23540 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23541 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23542 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23543 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23544 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23545 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23546 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23547 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23548 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23549 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23550 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23551 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23552 DATA (DL(K),K= 3316, 3400) /
23553 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23554 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23555 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23556 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23557 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23558 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23559 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23560 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23561 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23562 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23563 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23564 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23565 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23566 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23567 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23568 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23569 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23570 DATA (DL(K),K= 3401, 3485) /
23571 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23572 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23573 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23574 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23575 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23576 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23577 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23578 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23579 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23580 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23581 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23582 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23583 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23584 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23585 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23586 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23587 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23588 DATA (DL(K),K= 3486, 3570) /
23589 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23590 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23591 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23592 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23593 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23594 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23595 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23596 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23597 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23598 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23599 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23600 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23601 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23602 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23603 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23604 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23605 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23606 DATA (DL(K),K= 3571, 3655) /
23607 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23608 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23609 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23610 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23611 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23612 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23613 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23614 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23615 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23616 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23617 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23618 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23619 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23620 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23624 DATA (DL(K),K= 3656, 3740) /
23625 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23626 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23627 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23628 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23629 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23630 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23631 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23632 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23633 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23634 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23635 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23636 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23637 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23638 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23639 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23640 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23641 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23642 DATA (DL(K),K= 3741, 3825) /
23643 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23644 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23645 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23646 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23647 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23648 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23649 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23650 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23651 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23652 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23653 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23654 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23658 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23659 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23660 DATA (DL(K),K= 3826, 3910) /
23661 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23662 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23663 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23664 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23665 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23666 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23667 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23668 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23669 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23670 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23671 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23672 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23673 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23674 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23675 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23676 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23677 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23678 DATA (DL(K),K= 3911, 3995) /
23679 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23680 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23681 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23682 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23683 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23684 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23685 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23686 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23687 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23688 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23692 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23693 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23694 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23695 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23696 DATA (DL(K),K= 3996, 4000) /
23697 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23700 IF (X.GT.0.9985) RETURN
23701 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23707 F1(L) = GF(I,IS,KL)
23708 F2(L) = GF(I,IS1,KL)
23710 A1 = DT_CKMTFF(X,F1)
23711 A2 = DT_CKMTFF(X,F2)
23716 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23723 *$ CREATE DT_CKMTPR.FOR
23725 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23727 C**********************************************************************
23729 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23731 C This version by S. Roesler, 31.01.96
23732 C**********************************************************************
23735 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23736 EQUIVALENCE (GF(1,1,1),DL(1))
23739 DATA (DL(K),K= 1, 85) /
23740 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23741 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23742 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23743 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23744 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23745 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23746 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23747 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23748 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23749 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23750 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23751 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23752 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23753 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23754 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23755 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23756 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23757 DATA (DL(K),K= 86, 170) /
23758 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23759 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23760 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23761 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23762 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23763 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23764 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23765 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23766 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23767 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23768 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23769 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23770 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23771 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23772 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23773 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23774 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23775 DATA (DL(K),K= 171, 255) /
23776 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23777 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23778 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23779 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23780 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23781 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23782 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23783 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23784 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23785 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23786 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23787 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23788 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23789 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23790 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23791 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23792 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23793 DATA (DL(K),K= 256, 340) /
23794 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23795 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23796 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23797 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23798 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23799 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23800 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23801 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23802 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23803 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23804 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23805 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23806 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23807 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23808 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23809 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23810 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23811 DATA (DL(K),K= 341, 425) /
23812 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23813 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23814 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23815 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23816 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23817 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23818 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23819 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23820 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23821 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23822 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23823 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23824 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23825 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23826 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23827 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23828 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23829 DATA (DL(K),K= 426, 510) /
23830 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23831 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23832 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23833 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23834 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23835 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23836 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23837 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23838 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23839 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23840 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23841 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23842 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23843 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23844 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23845 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23846 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23847 DATA (DL(K),K= 511, 595) /
23848 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23849 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23850 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23851 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23852 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23853 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23854 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23855 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23856 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23857 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23858 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23859 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23860 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23861 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23862 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23863 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23864 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23865 DATA (DL(K),K= 596, 680) /
23866 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23867 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23868 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23869 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23870 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23871 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23872 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23873 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23874 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23875 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23876 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23877 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23878 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23879 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23880 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23881 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23882 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23883 DATA (DL(K),K= 681, 765) /
23884 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23885 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23886 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23887 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23888 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23889 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23890 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23891 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23892 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23893 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23894 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23895 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23896 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23897 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23898 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23899 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23900 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23901 DATA (DL(K),K= 766, 850) /
23902 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23903 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23904 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23905 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23906 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23907 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23908 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23909 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23910 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23911 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23912 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23913 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23914 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23915 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23916 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23917 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23918 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23919 DATA (DL(K),K= 851, 935) /
23920 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23921 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23922 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23923 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23924 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23925 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23926 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23927 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23928 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23929 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23930 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23931 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23932 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23933 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23934 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23935 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23936 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23937 DATA (DL(K),K= 936, 1020) /
23938 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23939 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23940 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23941 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23942 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23943 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23944 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23945 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23946 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23947 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23948 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23949 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23950 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23951 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23952 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23953 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23954 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23955 DATA (DL(K),K= 1021, 1105) /
23956 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23957 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23958 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23959 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23960 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23961 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23962 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23963 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23964 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23965 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23966 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23967 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23968 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23969 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23970 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23971 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23972 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23973 DATA (DL(K),K= 1106, 1190) /
23974 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23975 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23976 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23977 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23978 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23979 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23980 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23981 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23982 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23983 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23984 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23985 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23986 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23987 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23988 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23989 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23990 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23991 DATA (DL(K),K= 1191, 1275) /
23992 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23993 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23994 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23995 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23996 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23997 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23998 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23999 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24000 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24001 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24002 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24003 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24004 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24005 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24006 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24007 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24008 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24009 DATA (DL(K),K= 1276, 1360) /
24010 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24011 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24012 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24013 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24014 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24015 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24016 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24017 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24018 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24019 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24020 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24021 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24022 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24023 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24024 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24025 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24026 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24027 DATA (DL(K),K= 1361, 1445) /
24028 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24029 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24030 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24031 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24032 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24033 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24034 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24035 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24036 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24037 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24038 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24039 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24040 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24041 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24042 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24043 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24044 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24045 DATA (DL(K),K= 1446, 1530) /
24046 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24047 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24048 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24049 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24050 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24051 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24052 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24053 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24054 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24055 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24056 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24057 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24058 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24059 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24060 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24061 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24062 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24063 DATA (DL(K),K= 1531, 1615) /
24064 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24065 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24066 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24067 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24068 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24069 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24070 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24071 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24072 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24073 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24074 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24075 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24076 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24077 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24078 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24079 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24080 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24081 DATA (DL(K),K= 1616, 1700) /
24082 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24083 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24084 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24085 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24086 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24087 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24088 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24089 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24090 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24091 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24092 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24093 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24094 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24095 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24096 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24097 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24098 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24099 DATA (DL(K),K= 1701, 1785) /
24100 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24101 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24102 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24103 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24104 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24105 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24106 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24107 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24108 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24109 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24110 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24111 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24112 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24113 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24114 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24115 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24116 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24117 DATA (DL(K),K= 1786, 1870) /
24118 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24119 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24120 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24121 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24122 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24123 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24124 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24125 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24126 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24127 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24128 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24129 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24130 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24131 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24132 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24133 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24134 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24135 DATA (DL(K),K= 1871, 1955) /
24136 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24137 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24138 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24139 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24140 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24141 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24142 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24143 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24144 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24145 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24146 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24147 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24148 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24149 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24150 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24151 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24152 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24153 DATA (DL(K),K= 1956, 2040) /
24154 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24155 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24156 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24157 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24158 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24159 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24160 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24161 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24162 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24163 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24164 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24165 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24166 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24167 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24168 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24169 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24170 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24171 DATA (DL(K),K= 2041, 2125) /
24172 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24173 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24174 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24175 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24176 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24177 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24178 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24179 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24180 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24181 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24182 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24183 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24184 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24185 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24186 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24187 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24188 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24189 DATA (DL(K),K= 2126, 2210) /
24190 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24191 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24192 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24193 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24194 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24195 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24196 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24197 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24198 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24199 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24200 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24201 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24202 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24203 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24204 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24205 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24206 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24207 DATA (DL(K),K= 2211, 2295) /
24208 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24209 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24210 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24211 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24212 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24213 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24214 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24215 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24216 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24217 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24218 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24219 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24220 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24221 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24222 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24223 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24224 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24225 DATA (DL(K),K= 2296, 2380) /
24226 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24227 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24228 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24229 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24230 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24231 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24232 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24233 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24234 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24235 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24236 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24237 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24238 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24239 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24240 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24241 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24242 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24243 DATA (DL(K),K= 2381, 2465) /
24244 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24245 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24246 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24247 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24248 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24249 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24250 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24251 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24252 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24253 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24254 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24255 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24256 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24257 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24258 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24259 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24260 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24261 DATA (DL(K),K= 2466, 2550) /
24262 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24263 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24264 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24265 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24266 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24267 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24268 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24269 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24270 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24271 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24272 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24273 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24274 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24275 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24276 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24277 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24278 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24279 DATA (DL(K),K= 2551, 2635) /
24280 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24281 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24282 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24283 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24284 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24285 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24286 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24287 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24288 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24289 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24290 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24291 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24292 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24293 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24294 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24295 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24296 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24297 DATA (DL(K),K= 2636, 2720) /
24298 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24299 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24300 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24301 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24302 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24303 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24304 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24305 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24306 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24307 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24308 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24309 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24310 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24311 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24312 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24313 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24314 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24315 DATA (DL(K),K= 2721, 2805) /
24316 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24317 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24318 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24319 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24320 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24321 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24322 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24323 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24324 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24325 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24326 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24327 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24328 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24329 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24330 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24331 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24332 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24333 DATA (DL(K),K= 2806, 2890) /
24334 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24335 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24336 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24337 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24338 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24339 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24340 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24341 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24342 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24343 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24344 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24345 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24346 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24347 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24348 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24349 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24350 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24351 DATA (DL(K),K= 2891, 2975) /
24352 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24353 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24354 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24355 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24356 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24357 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24358 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24359 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24360 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24361 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24362 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24363 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24364 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24365 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24366 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24367 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24368 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24369 DATA (DL(K),K= 2976, 3060) /
24370 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24371 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24372 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24373 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24374 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24375 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24376 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24377 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24378 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24379 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24380 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24381 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24382 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24383 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24384 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24385 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24386 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24387 DATA (DL(K),K= 3061, 3145) /
24388 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24389 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24390 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24391 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24392 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24393 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24394 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24395 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24396 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24397 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24398 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24399 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24400 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24401 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24402 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24403 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24404 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24405 DATA (DL(K),K= 3146, 3230) /
24406 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24407 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24408 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24409 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24410 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24411 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24412 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24413 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24414 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24415 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24416 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24417 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24418 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24419 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24420 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24421 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24422 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24423 DATA (DL(K),K= 3231, 3315) /
24424 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24425 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24426 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24427 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24428 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24429 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24430 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24431 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24432 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24433 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24434 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24435 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24436 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24437 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24438 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24439 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24440 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24441 DATA (DL(K),K= 3316, 3400) /
24442 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24443 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24444 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24445 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24446 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24447 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24448 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24449 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24450 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24451 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24452 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24453 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24454 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24455 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24456 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24457 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24458 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24459 DATA (DL(K),K= 3401, 3485) /
24460 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24461 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24462 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24463 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24464 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24465 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24466 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24467 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24468 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24469 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24470 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24471 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24472 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24473 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24474 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24475 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24476 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24477 DATA (DL(K),K= 3486, 3570) /
24478 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24479 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24480 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24481 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24482 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24483 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24484 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24485 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24486 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24487 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24488 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24489 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24490 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24491 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24492 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24493 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24494 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24495 DATA (DL(K),K= 3571, 3655) /
24496 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24497 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24498 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24499 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24500 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24501 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24502 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24503 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24504 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24505 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24506 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24507 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24508 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24509 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24510 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24511 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24512 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24513 DATA (DL(K),K= 3656, 3740) /
24514 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24515 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24516 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24517 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24518 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24519 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24520 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24521 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24522 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24523 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24524 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24525 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24526 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24527 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24528 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24529 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24530 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24531 DATA (DL(K),K= 3741, 3825) /
24532 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24533 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24534 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24535 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24536 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24537 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24538 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24539 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24540 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24541 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24542 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24543 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24544 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24545 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24546 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24547 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24548 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24549 DATA (DL(K),K= 3826, 3910) /
24550 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24551 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24552 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24553 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24554 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24555 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24556 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24557 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24558 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24559 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24560 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24561 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24562 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24563 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24564 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24565 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24566 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24567 DATA (DL(K),K= 3911, 3995) /
24568 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24569 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24570 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24571 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24572 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24573 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24574 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24575 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24576 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24577 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24578 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24579 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24580 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24581 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24582 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24583 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24584 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24585 DATA (DL(K),K= 3996, 4000) /
24586 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24589 IF (X.GT.0.9985) RETURN
24590 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24596 F1(L) = GF(I,IS,KL)
24597 F2(L) = GF(I,IS1,KL)
24599 A1 = DT_CKMTFF(X,F1)
24600 A2 = DT_CKMTFF(X,F2)
24605 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24611 *$ CREATE DT_CKMTFF.FOR
24613 FUNCTION DT_CKMTFF(X,FVL)
24614 C**********************************************************************
24616 C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24617 C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24618 C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24621 C**********************************************************************
24624 DIMENSION FVL(25),XGRID(25)
24625 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24626 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24630 IF(X.LT.XGRID(I)) GO TO 2
24635 ELSE IF(I.GT.23) THEN
24641 BXI=LOG(1.-XGRID(I))
24643 BXJ=LOG(1.-XGRID(J))
24645 BXK=LOG(1.-XGRID(K))
24646 FI=LOG(ABS(FVL(I)) +1.E-15)
24647 FJ=LOG(ABS(FVL(J)) +1.E-16)
24648 FK=LOG(ABS(FVL(K)) +1.E-17)
24649 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24650 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24652 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24653 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24654 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24656 C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24657 C WRITE(6,2001) X,FVL
24658 C 2001 FORMAT(8E12.4)
24659 C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24661 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24665 *$ CREATE DT_FLUINI.FOR
24668 *===fluini=============================================================*
24670 SUBROUTINE DT_FLUINI
24672 ************************************************************************
24673 * Initialisation of the nucleon-nucleon cross section fluctuation *
24674 * treatment. The original version by J. Ranft. *
24675 * This version dated 21.04.95 is revised by S. Roesler. *
24676 ************************************************************************
24678 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24680 PARAMETER ( LINP = 10 ,
24683 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24685 PARAMETER ( A = 0.1D0,
24691 * n-n cross section fluctuations
24692 PARAMETER (NBINS = 1000)
24693 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24694 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24697 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24706 FLUS = ((X-B)/(OM*B))**N
24707 IF (FLUS.LE.20.0D0) THEN
24708 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24712 FLUSU = FLUSU+FLUSI(I)
24715 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24720 C1001 FORMAT(1X,'FLUCTUATIONS')
24721 C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24724 AF = DBLE(I)*0.001D0
24726 IF (AF.LE.FLUSI(J)) THEN
24727 FLUIXX(I) = FLUIX(J)
24733 FLUIXX(1) = FLUIX(1)
24734 FLUIXX(NBINS) = FLUIX(NBINS)
24739 *$ CREATE DT_SIGTBL.FOR
24742 *===sigtab=============================================================*
24744 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24746 ************************************************************************
24747 * This version dated 18.11.95 is written by S. Roesler *
24748 ************************************************************************
24750 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24752 PARAMETER ( LINP = 10 ,
24756 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24757 & OHALF=0.5D0,ONE=1.0D0)
24758 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24762 * particle properties (BAMJET index convention)
24764 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24765 & IICH(210),IIBAR(210),K1(210),K2(210)
24767 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24768 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24769 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24771 DATA LINIT /.FALSE./
24773 * precalculation and tabulation of elastic cross sections
24774 IF (ABS(MODE).EQ.1) THEN
24776 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24777 PLABLX = LOG10(PLO)
24778 PLABHX = LOG10(PHI)
24779 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24781 PLAB = PLABLX+DBLE(I-1)*DPLAB
24786 C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24787 C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24789 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24790 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24793 IF (MODE.EQ.1) THEN
24794 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24795 & (SIGEN(IDX,I),IDX=1,5)
24796 1000 FORMAT(F5.1,10F7.2)
24799 IF (MODE.EQ.1) CLOSE(LDAT)
24803 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24804 & .AND.(PTOT.LE.PHI) ) THEN
24806 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24807 PLABX = LOG10(PTOT)
24808 IF (PLABX.LE.PLABLX) THEN
24811 ELSEIF (PLABX.GE.PLABHX) THEN
24815 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24818 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24819 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24820 PBIN = PLAB2X-PLAB1X
24821 IF (PBIN.GT.TINY10) THEN
24822 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24827 SIG1 = SIGEP(IDX,I1)
24828 SIG2 = SIGEP(IDX,I2)
24830 SIG1 = SIGEN(IDX,I1)
24831 SIG2 = SIGEN(IDX,I2)
24833 SIGE = SIG1+RATX*(SIG2-SIG1)
24841 *$ CREATE DT_XSTABL.FOR
24844 *===xstabl=============================================================*
24846 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24848 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24850 PARAMETER ( LINP = 10 ,
24853 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24854 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24855 LOGICAL LLAB,LELOG,LQLOG
24857 * particle properties (BAMJET index convention)
24859 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24860 & IICH(210),IIBAR(210),K1(210),K2(210)
24861 * properties of interacting particles
24862 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24863 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24864 * Glauber formalism: cross sections
24865 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24866 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24867 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24868 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24869 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24870 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24871 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24872 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24873 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24874 & BSLOPE,NEBINI,NQBINI
24875 * emulsion treatment
24876 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24881 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24884 IF (ELO.GT.EHI) ELO = EHI
24885 LELOG = WHAT(3).LT.ZERO
24886 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24887 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24891 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24895 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24896 LQLOG = WHAT(6).LT.ZERO
24897 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24898 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24900 AQ2LO = LOG10(Q2LO)
24901 AQ2HI = LOG10(Q2HI)
24902 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24905 IF ( ELO.EQ. EHI) NEBINS = 0
24906 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24908 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24909 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24910 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24911 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24912 & ' A_p = ',I3,' A_t = ',I3,/)
24914 C IF (IJPROJ.NE.7) THEN
24915 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24916 * normalize fractions of emulsion components
24917 IF (NCOMPO.GT.0) THEN
24920 SUMFRA = SUMFRA+EMUFRA(I)
24922 IF (SUMFRA.GT.ZERO) THEN
24924 EMUFRA(I) = EMUFRA(I)/SUMFRA
24929 C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24933 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24935 E = ELO+DBLE(I-1)*DEBINS
24939 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24941 Q2 = Q2LO+DBLE(J-1)*DQBINS
24943 c IF (IJPROJ.NE.7) THEN
24947 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24953 IF (IJPROJ.EQ.7) Q2I = Q2
24954 IF (NCOMPO.GT.0) THEN
24957 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24960 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24961 C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24963 IF (NCOMPO.GT.0) THEN
24982 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24983 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24984 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24985 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24986 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24987 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24988 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24989 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24990 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24991 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24992 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24993 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24994 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24995 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24996 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24997 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24998 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24999 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
25001 XPRO1= XPRO1+EMUFRA(IC)*YPRO
25011 WRITE(LOUT,'(8E9.3)')
25012 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25013 C WRITE(LOUT,'(4E9.3)')
25014 C & E,XDEL,XDQE,XDEL+XDQE
25016 WRITE(LOUT,'(11E10.3)')
25018 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25019 & XSQE2(1,1,1),XSPRO(1,1,1),
25020 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25021 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25022 & XSDEL(1,1,1)+XSDQE(1,1,1)
25023 C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25024 C & XSDEL(1,1,1)+XSDQE(1,1,1)
25028 c IF (IT.GT.1) THEN
25029 c IF (IXSQEL.EQ.0) THEN
25030 cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
25031 cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
25032 c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25033 c & STOT,ETOT,SIN,EIN,STOT0)
25034 c IF (IRATIO.EQ.1) THEN
25035 c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25036 cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25037 cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25038 c*!! save cross sections
25043 c STOT = STOT/(DBLE(IT)*STGP)
25044 c SIN = SIN/(DBLE(IT)*SIGP)
25051 c & ' XSTABL: qel. xs. not implemented for nuclei'
25058 c IF (IXSQEL.EQ.0) THEN
25059 c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25062 c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25066 c IF (IT.GT.1) THEN
25067 c IF (IXSQEL.EQ.0) THEN
25068 c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25069 c & STOT,ETOT,SIN,EIN,STOT0)
25070 c IF (IRATIO.EQ.1) THEN
25071 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25072 c*!! save cross sections
25077 c STOT = STOT/(DBLE(IT)*STGP)
25078 c SIN = SIN/(DBLE(IT)*SIGP)
25085 c & ' XSTABL: qel. xs. not implemented for nuclei'
25092 c IF (IXSQEL.EQ.0) THEN
25093 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25096 c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25100 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25101 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25102 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25103 c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25111 *$ CREATE DT_TESTXS.FOR
25114 *===testxs=============================================================*
25116 SUBROUTINE DT_TESTXS
25118 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25121 DIMENSION XSTOT(26,2),XSELA(26,2)
25123 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25124 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25125 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25126 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25131 APLABL = LOG10(PLABL)
25132 APLABH = LOG10(PLABH)
25133 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25135 ADP = APLABL+DBLE(I-1)*ADPLAB
25138 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25139 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25141 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25142 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25143 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25144 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25146 1000 FORMAT(F8.3,26F9.3)
25151 ************************************************************************
25153 * DTUNUC 2.0: library routines *
25154 * processed by S. Roesler, 6.5.95 *
25156 ************************************************************************
25158 * 1) Handling of parton momenta
25159 * SUBROUTINE MASHEL
25160 * SUBROUTINE DFERMI
25162 * 2) Handling of parton flavors and particle indices
25163 * INTEGER FUNCTION IPDG2B
25164 * INTEGER FUNCTION IB2PDG
25165 * INTEGER FUNCTION IQUARK
25166 * INTEGER FUNCTION IBJQUA
25167 * INTEGER FUNCTION ICIHAD
25168 * INTEGER FUNCTION IPDGHA
25169 * INTEGER FUNCTION MCHAD
25170 * SUBROUTINE FLAHAD
25172 * 3) Energy-momentum and quantum number conservation check routines
25175 * SUBROUTINE EVTEMC
25176 * SUBROUTINE EVTFLC
25177 * SUBROUTINE EVTCHG
25179 * 4) Transformations
25181 * SUBROUTINE LTRANS
25183 * SUBROUTINE DALTRA
25184 * SUBROUTINE DTRAFO
25185 * SUBROUTINE STTRAN
25186 * SUBROUTINE MYTRAN
25187 * SUBROUTINE LT2LAO
25188 * SUBROUTINE LT2LAB
25190 * 5) Sampling from distributions
25191 * INTEGER FUNCTION NPOISS
25192 * DOUBLE PRECISION FUNCTION SAMPXB
25193 * DOUBLE PRECISION FUNCTION SAMPEX
25194 * DOUBLE PRECISION FUNCTION SAMSQX
25195 * DOUBLE PRECISION FUNCTION BETREJ
25196 * DOUBLE PRECISION FUNCTION DGAMRN
25197 * DOUBLE PRECISION FUNCTION DBETAR
25198 * SUBROUTINE RANNOR
25200 * SUBROUTINE DSFECF
25203 * 6) Special functions, algorithms and service routines
25204 * DOUBLE PRECISION FUNCTION YLAMB
25207 * SUBROUTINE DT_XTIME
25209 * 7) Random number generator package
25210 * DOUBLE PRECISION FUNCTION DT_RNDM
25211 * SUBROUTINE DT_RNDMST
25212 * SUBROUTINE DT_RNDMIN
25213 * SUBROUTINE DT_RNDMOU
25214 * SUBROUTINE DT_RNDMTE
25216 ************************************************************************
25218 * 1) Handling of parton momenta *
25220 ************************************************************************
25221 *$ CREATE DT_MASHEL.FOR
25224 *===mashel=============================================================*
25226 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25228 ************************************************************************
25230 * rescaling of momenta of two partons to put both *
25233 * input: PA1,PA2 input momentum vectors *
25234 * XM1,2 desired masses of particles afterwards *
25235 * P1,P2 changed momentum vectors *
25237 * The original version is written by R. Engel. *
25238 * This version dated 12.12.94 is modified by S. Roesler. *
25239 ************************************************************************
25241 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25243 PARAMETER ( LINP = 10 ,
25246 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25248 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25252 * Lorentz transformation into system CMS
25257 XPTOT = SQRT(PX**2+PY**2+PZ**2)
25258 XMS = (EE-XPTOT)*(EE+XPTOT)
25259 IF(XMS.LT.(XM1+XM2)**2) THEN
25260 C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25268 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25269 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25272 C SID = SQRT((ONE-COD)*(ONE+COD))
25273 PPT = SQRT(P1(1)**2+P1(2)**2)
25277 IF(PTOT1*SID.GT.TINY10) THEN
25278 COF = P1(1)/(SID*PTOT1)
25279 SIF = P1(2)/(SID*PTOT1)
25280 ANORF = SQRT(COF*COF+SIF*SIF)
25284 * new CM momentum and energies (for masses XM1,XM2)
25285 XM12 = SIGN(XM1**2,XM1)
25286 XM22 = SIGN(XM2**2,XM2)
25288 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25289 EE1 = SQRT(XM12+PCMP**2)
25293 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25294 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25295 & PTOT1,P1(1),P1(2),P1(3),P1(4))
25296 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25297 & PTOT2,P2(1),P2(2),P2(3),P2(4))
25298 * check consistency
25300 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25302 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25304 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25306 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25311 IF (IDEV.NE.0) THEN
25312 WRITE(LOUT,'(/1X,A,I3)')
25313 & 'MASHEL: inconsistent transformation',IDEV
25314 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25315 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25316 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25317 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25318 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25319 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25328 *$ CREATE DT_DFERMI.FOR
25331 *===dfermi=============================================================*
25333 SUBROUTINE DT_DFERMI(GPART)
25335 ************************************************************************
25336 * Find largest of three random numbers. *
25337 ************************************************************************
25339 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25345 G(I)=DT_RNDM(GPART)
25347 IF (G(3).LT.G(2)) GOTO 40
25348 IF (G(3).LT.G(1)) GOTO 30
25353 40 IF (G(2).LT.G(1)) GOTO 30
25359 ************************************************************************
25361 * 2) Handling of parton flavors and particle indices *
25363 ************************************************************************
25364 *$ CREATE IDT_IPDG2B.FOR
25367 *===ipdg2b=============================================================*
25369 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25371 ************************************************************************
25373 * conversion of quark numbering scheme *
25375 * input: PDG parton numbering *
25376 * for diquarks: NN number of the constituent quark *
25377 * (e.g. ID=2301,NN=1 -> ICONV2=1) *
25379 * output: BAMJET particle codes *
25380 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25381 * 2 d 8 a-d -2 a-d *
25382 * 3 s 9 a-s -3 a-s *
25383 * 4 c 10 a-c -4 a-c *
25385 * This is a modified version of ICONV2 written by R. Engel. *
25386 * This version dated 13.12.94 is written by S. Roesler. *
25387 ************************************************************************
25389 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25391 PARAMETER ( LINP = 10 ,
25399 IF (IDA.GE.1000) KF = 4
25400 IDA = IDA/(10**(KF-NN))
25403 * exchange up and dn quarks
25406 ELSEIF (IDA.EQ.2) THEN
25411 IF (MODE.EQ.1) THEN
25422 *$ CREATE IDT_IB2PDG.FOR
25425 *===ib2pdg=============================================================*
25427 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25429 ************************************************************************
25431 * conversion of quark numbering scheme *
25433 * input: BAMJET particle codes *
25434 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25435 * 2 d 8 a-d -2 a-d *
25436 * 3 s 9 a-s -3 a-s *
25437 * 4 c 10 a-c -4 a-c *
25439 * output: PDG parton numbering *
25441 * This version dated 13.12.94 is written by S. Roesler. *
25442 ************************************************************************
25444 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25446 PARAMETER ( LINP = 10 ,
25450 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25451 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25452 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25453 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25454 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25458 IF (MODE.EQ.1) THEN
25459 IF (ID1.GT.6) IDA = -(ID1-6)
25460 IF (ID2.GT.6) IDB = -(ID2-6)
25463 IDT_IB2PDG = IHKKQ(IDA)
25465 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25471 *$ CREATE IDT_IQUARK.FOR
25474 *===ipdgqu=============================================================*
25476 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25478 ************************************************************************
25480 * quark contents according to PDG conventions *
25481 * (random selection in case of quark mixing) *
25483 * input: IDBAMJ BAMJET particle code *
25484 * K 1..3 quark number *
25486 * output: 1 d (anti --> neg.) *
25491 * This version written by R. Engel. *
25492 ************************************************************************
25494 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25497 IQ = IDT_IBJQUA(K,IDBAMJ)
25502 * exchange of up and down
25503 IF (ABS(IQ).EQ.1) THEN
25505 ELSEIF (ABS(IQ).EQ.2) THEN
25513 *$ CREATE IDT_IBJQUA.FOR
25516 *===ibamq==============================================================*
25518 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25520 ************************************************************************
25522 * quark contents according to BAMJET conventions *
25523 * (random selection in case of quark mixing) *
25525 * input: IDBAMJ BAMJET particle code *
25526 * K 1..3 quark number *
25528 * output: 1 u 7 u bar *
25533 * This version written by R. Engel. *
25534 ************************************************************************
25536 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25539 DIMENSION ITAB(3,210)
25540 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25541 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25542 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25543 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25545 C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25546 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25548 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25550 C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25551 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25553 C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25554 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25556 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25557 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25558 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25559 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25560 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25561 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25562 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
25563 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25564 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25565 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25566 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25567 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
25568 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25569 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25570 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25571 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25572 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25573 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25574 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25575 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25576 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25577 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25578 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25579 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25580 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25581 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25582 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25583 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25584 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25585 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25586 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25587 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25588 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25589 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25590 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25591 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25592 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25593 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25594 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25595 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25596 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25597 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25598 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25599 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25600 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25601 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25602 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25603 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25604 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25605 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25606 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25607 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25608 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25609 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25610 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25611 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25612 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25613 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25614 DATA ((ITAB(I,K),I=1,3),K=181,210) /
25615 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25616 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25617 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25618 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25619 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25620 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25621 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25622 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25623 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25624 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25628 IF (ITAB(1,IDBAMJ).LE.200) THEN
25629 ID = ITAB(K,IDBAMJ)
25631 IF(IDOLD.NE.IDBAMJ) THEN
25632 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25633 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25645 *$ CREATE IDT_ICIHAD.FOR
25648 *===icihad=============================================================*
25650 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25652 ************************************************************************
25653 * Conversion of particle index PDG proposal --> BAMJET-index scheme *
25654 * This is a completely new version dated 25.10.95. *
25655 * Renamed to be not in conflict with the modified PHOJET-version *
25656 ************************************************************************
25658 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25661 * hadron index conversion (BAMJET <--> PDG)
25662 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25663 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25668 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25669 IF (MCIND.LT.0) THEN
25674 IF (KPDG.GE.10000) THEN
25676 IDT_ICIHAD = IBAM5(JSIGN,I)
25677 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25680 ELSEIF (KPDG.GE.1000) THEN
25682 IDT_ICIHAD = IBAM4(JSIGN,I)
25683 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25686 ELSEIF (KPDG.GE.100) THEN
25688 IDT_ICIHAD = IBAM3(JSIGN,I)
25689 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25692 ELSEIF (KPDG.GE.10) THEN
25694 IDT_ICIHAD = IBAM2(JSIGN,I)
25695 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25704 *$ CREATE IDT_IPDGHA.FOR
25707 *===ipdgha=============================================================*
25709 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25711 ************************************************************************
25712 * Conversion of particle index BAMJET-index scheme --> PDG proposal *
25713 * Adopted from the original by S. Roesler. This version dated 12.5.95 *
25714 * Renamed to be not in conflict with the modified PHOJET-version *
25715 ************************************************************************
25717 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25720 * hadron index conversion (BAMJET <--> PDG)
25721 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25722 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25725 IDT_IPDGHA = IAMCIN(MCIND)
25730 *$ CREATE DT_FLAHAD.FOR
25733 *===flahad=============================================================*
25735 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25737 ************************************************************************
25738 * sampling of FLAvor composition for HADrons/photons *
25739 * ID BAMJET-id of hadron *
25740 * IF1,2,3 flavor content *
25741 * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25742 * Note: - u,d numbering as in BAMJET *
25743 * - ID .le. 30 !! *
25744 * This version dated 12.03.96 is written by S. Roesler *
25745 ************************************************************************
25747 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25750 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25751 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25752 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25753 & IQTCHR(-6:6),MQUARK(3,39)
25755 DIMENSION JSEL(3,6)
25756 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25760 * photon (charge dependent flavour sampling)
25761 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25765 ELSE IF(K.EQ.5) THEN
25772 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25780 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25781 IF1 = MQUARK(JSEL(1,IX),ID)
25782 IF2 = MQUARK(JSEL(2,IX),ID)
25783 IF3 = MQUARK(JSEL(3,IX),ID)
25784 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25787 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25796 *$ CREATE IDT_MCHAD.FOR
25799 *===mchad==============================================================*
25801 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25803 ************************************************************************
25804 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25805 * Adopted from the original by S. Roesler. This version dated 6.5.95 *
25807 * Last change 28.12.2006 by S. Roesler. *
25808 ************************************************************************
25810 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25813 DIMENSION ITRANS(210)
25814 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25815 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25816 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25817 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25818 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25819 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25820 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25822 IF ( ITDTU .GT. 0 ) THEN
25823 IDT_MCHAD = ITRANS(ITDTU)
25831 ************************************************************************
25833 * 3) Energy-momentum and quantum number conservation check routines *
25835 ************************************************************************
25836 *$ CREATE DT_EMC1.FOR
25839 *===emc1===============================================================*
25841 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25843 ************************************************************************
25844 * This version dated 15.12.94 is written by S. Roesler *
25845 ************************************************************************
25847 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25849 PARAMETER ( LINP = 10 ,
25852 PARAMETER (TINY10=1.0D-10)
25854 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25858 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25859 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25861 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25862 IF (MODE.EQ.1) THEN
25863 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25864 ELSEIF (MODE.EQ.2) THEN
25865 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25867 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25868 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25869 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25870 ELSEIF (MODE.LT.0) THEN
25871 IF (MODE.EQ.-1) THEN
25872 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25873 ELSEIF (MODE.EQ.-2) THEN
25874 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25876 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25877 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25878 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25881 IF (ABS(MODE).EQ.3) THEN
25882 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25883 IF (IREJ1.NE.0) GOTO 9999
25892 *$ CREATE DT_EMC2.FOR
25895 *===emc2===============================================================*
25897 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25900 ************************************************************************
25901 * MODE = 1 energy-momentum cons. check *
25902 * = 2 flavor-cons. check *
25903 * = 3 energy-momentum & flavor cons. check *
25904 * = 4 energy-momentum & charge cons. check *
25905 * = 5 energy-momentum & flavor & charge cons. check *
25906 * This version dated 16.01.95 is written by S. Roesler *
25907 ************************************************************************
25909 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25911 PARAMETER ( LINP = 10 ,
25914 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25917 PARAMETER (NMXHKK=200000)
25918 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25919 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25920 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25921 * extended event history
25922 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25923 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25931 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25932 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25933 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25934 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25935 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25937 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25938 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25939 & (ISTHKK(I).EQ.IP5)) THEN
25940 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25942 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25944 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25945 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25946 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25947 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25949 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25950 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25951 & (ISTHKK(I).EQ.IN5)) THEN
25952 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25954 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25956 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25957 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25958 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25959 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25962 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25963 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25964 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25965 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25966 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25967 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25976 *$ CREATE DT_EVTEMC.FOR
25979 *===evtemc=============================================================*
25981 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25983 ************************************************************************
25984 * This version dated 13.12.94 is written by S. Roesler *
25985 ************************************************************************
25987 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25989 PARAMETER ( LINP = 10 ,
25992 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25996 PARAMETER (NMXHKK=200000)
25997 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25998 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25999 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26000 * flags for input different options
26001 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26002 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26003 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26009 IF (MODE.EQ.4) THEN
26012 ELSEIF (MODE.EQ.5) THEN
26015 ELSEIF (MODE.EQ.-1) THEN
26020 IF (ABS(MODE).EQ.3) THEN
26025 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26026 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26027 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26028 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26029 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26030 & ' event ',NEVHKK,
26031 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26045 IF (MODE.EQ.1) THEN
26064 *$ CREATE DT_EVTFLC.FOR
26067 *===evtflc=============================================================*
26069 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26071 ************************************************************************
26072 * Flavor conservation check. *
26073 * ID identity of particle *
26074 * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
26075 * = 2 ID for particle/resonance in BAMJET numbering scheme *
26076 * = 3 ID for particle/resonance in PDG numbering scheme *
26077 * MODE = 1 initialization and add ID *
26078 * =-1 initialization and subtract ID *
26080 * =-2 subtract ID *
26081 * = 3 check flavor cons. *
26082 * IPOS flag to give position of call of EVTFLC to output *
26083 * unit in case of violation *
26084 * This version dated 10.01.95 is written by S. Roesler *
26085 ************************************************************************
26087 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26089 PARAMETER ( LINP = 10 ,
26092 PARAMETER (TINY10=1.0D-10)
26096 IF (MODE.EQ.3) THEN
26098 WRITE(LOUT,'(1X,A,I3,A,I3)')
26099 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26108 IF (MODE.EQ.1) IFL = 0
26109 IF (ID.EQ.0) RETURN
26114 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26115 IF (IDD.GE.1000) NQ = 3
26117 IFBAM = IDT_IPDG2B(ID,I,2)
26118 IF (ABS(IFBAM).EQ.1) THEN
26119 IFBAM = SIGN(2,IFBAM)
26120 ELSEIF (ABS(IFBAM).EQ.2) THEN
26121 IFBAM = SIGN(1,IFBAM)
26123 IF (MODE.GT.0) THEN
26133 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26134 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26136 IF (MODE.GT.0) THEN
26137 IFL = IFL+IDT_IQUARK(I,IDD)
26139 IFL = IFL-IDT_IQUARK(I,IDD)
26150 *$ CREATE DT_EVTCHG.FOR
26153 *===evtchg=============================================================*
26155 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26157 ************************************************************************
26158 * Charge conservation check. *
26159 * ID identity of particle (PDG-numbering scheme) *
26160 * MODE = 1 initialization *
26161 * =-2 subtract ID-charge *
26162 * = 2 add ID-charge *
26163 * = 3 check charge cons. *
26164 * IPOS flag to give position of call of EVTCHG to output *
26165 * unit in case of violation *
26166 * This version dated 10.01.95 is written by S. Roesler *
26167 * Last change: s.r. 21.01.01 *
26168 ************************************************************************
26170 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26172 PARAMETER ( LINP = 10 ,
26177 PARAMETER (NMXHKK=200000)
26178 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26179 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26180 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26181 * particle properties (BAMJET index convention)
26183 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26184 & IICH(210),IIBAR(210),K1(210),K2(210)
26188 IF (MODE.EQ.1) THEN
26194 IF (MODE.EQ.3) THEN
26195 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26196 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26197 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26198 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26208 IF (ID.EQ.0) RETURN
26210 IDD = IDT_ICIHAD(ID)
26211 * modification 21.1.01: use intrinsic phojet-functions to determine charge
26212 * and baryon number
26213 C IF (IDD.GT.0) THEN
26214 C IF (MODE.EQ.2) THEN
26215 C ICH = ICH+IICH(IDD)
26216 C IBAR = IBAR+IIBAR(IDD)
26217 C ELSEIF (MODE.EQ.-2) THEN
26218 C ICH = ICH-IICH(IDD)
26219 C IBAR = IBAR-IIBAR(IDD)
26222 C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26223 C CALL DT_EVTOUT(4)
26226 IF (MODE.EQ.2) THEN
26227 ICH = ICH+IPHO_CHR3(ID,1)/3
26228 IBAR = IBAR+IPHO_BAR3(ID,1)/3
26229 ELSEIF (MODE.EQ.-2) THEN
26230 ICH = ICH-IPHO_CHR3(ID,1)/3
26231 IBAR = IBAR-IPHO_BAR3(ID,1)/3
26241 ************************************************************************
26243 * 4) Transformations *
26245 ************************************************************************
26246 *$ CREATE DT_LTINI.FOR
26249 *===ltini==============================================================*
26251 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26253 ************************************************************************
26254 * Initializations of Lorentz-transformations, calculation of Lorentz- *
26256 * This version dated 13.11.95 is written by S. Roesler. *
26257 ************************************************************************
26259 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26261 PARAMETER ( LINP = 10 ,
26264 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26265 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26267 * Lorentz-parameters of the current interaction
26268 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26269 & UMO,PPCM,EPROJ,PPROJ
26270 * properties of photon/lepton projectiles
26271 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26272 * particle properties (BAMJET index convention)
26274 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26275 & IICH(210),IIBAR(210),K1(210),K2(210)
26276 * nucleon-nucleon event-generator
26279 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26283 IF (MCGENE.NE.3) THEN
26284 * lepton-projectiles and PHOJET: initialize real photon instead
26285 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26286 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26287 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26296 AMP = AAM(IDP)-SQRT(ABS(Q2))
26298 AMP2 = SIGN(AMP**2,AMP)
26300 IF (ECM0.GT.ZERO) THEN
26301 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26302 IF (AMP2.GT.ZERO) THEN
26303 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26305 PPN = SQRT(EPN**2-AMP2)
26308 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26309 IF (IDP.EQ.7) EPN = ABS(EPN)
26310 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26311 IF (AMP2.GT.ZERO) THEN
26312 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26314 PPN = SQRT(EPN**2-AMP2)
26316 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26317 IF (AMP2.GT.ZERO) THEN
26318 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26320 EPN = SQRT(PPN**2+AMP2)
26323 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26328 IF (AMP2.GT.ZERO) THEN
26329 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26330 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26335 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26341 IF (ECM0.GT.ZERO) THEN
26344 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26345 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26346 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26347 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26350 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26351 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26352 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26353 IF (MODE.EQ.1) THEN
26356 PNUCL(3) = -PGAMM(3)
26357 PNUCL(4) = SQRT(S)-PGAMM(4)
26360 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26361 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26364 * neglect lepton masses
26365 C AMLPT2 = AAM(IDPR)**2
26368 IF (ECM0.GT.ZERO) THEN
26371 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26372 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26373 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26374 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26377 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26378 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26379 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26382 PNUCL(3) = -PLEPT0(3)
26383 PNUCL(4) = SQRT(S)-PLEPT0(4)
26385 * Lorentz-parameter for transformation Lab. - projectile rest system
26386 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26395 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26400 GACMS(1) = (ETARG+AMP)/UMO
26401 BGCMS(1) = PTARG/UMO
26403 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26404 GACMS(2) = (EPROJ+AMT)/UMO
26405 BGCMS(2) = PPROJ/UMO
26406 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26415 *$ CREATE DT_LTRANS.FOR
26418 *===ltrans=============================================================*
26420 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26422 ************************************************************************
26423 * Lorentz-transformations. *
26424 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
26425 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26426 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26427 * This version dated 01.11.95 is written by S. Roesler. *
26428 ************************************************************************
26430 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26432 PARAMETER ( LINP = 10 ,
26435 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26437 PARAMETER (SQTINF=1.0D+15)
26439 * particle properties (BAMJET index convention)
26441 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26442 & IICH(210),IIBAR(210),K1(210),K2(210)
26446 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26448 * check particle mass for consistency (numerical rounding errors)
26449 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26450 AMO2 = (PEO-PO)*(PEO+PO)
26451 AMORQ2 = AAM(ID)**2
26452 AMDIF2 = ABS(AMO2-AMORQ2)
26453 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26454 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26460 C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26466 *$ CREATE DT_LTNUC.FOR
26469 *===ltnuc==============================================================*
26471 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26473 ************************************************************************
26474 * Lorentz-transformations. *
26475 * PIN longitudnal momentum (input) *
26476 * EIN energy (input) *
26477 * POUT transformed long. momentum (output) *
26478 * EOUT transformed energy (output) *
26479 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
26480 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26481 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26482 * This version dated 01.11.95 is written by S. Roesler. *
26483 ************************************************************************
26485 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26487 PARAMETER ( LINP = 10 ,
26490 PARAMETER (ZERO=0.0D0)
26492 * Lorentz-parameters of the current interaction
26493 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26494 & UMO,PPCM,EPROJ,PPROJ
26500 IF (ABS(MODE).EQ.1) THEN
26501 BG = -SIGN(BGLAB,DBLE(MODE))
26502 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26503 & DUM1,DUM2,DUM3,POUT,EOUT)
26504 ELSEIF (ABS(MODE).EQ.2) THEN
26505 BG = SIGN(BGCMS(1),DBLE(MODE))
26506 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26507 & DUM1,DUM2,DUM3,POUT,EOUT)
26508 ELSEIF (ABS(MODE).EQ.3) THEN
26509 BG = -SIGN(BGCMS(2),DBLE(MODE))
26510 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26511 & DUM1,DUM2,DUM3,POUT,EOUT)
26513 WRITE(LOUT,1000) MODE
26514 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26522 *$ CREATE DT_DALTRA.FOR
26525 *===daltra=============================================================*
26527 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26529 ************************************************************************
26530 * Arbitrary Lorentz-transformation. *
26531 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26532 ************************************************************************
26534 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26536 PARAMETER (ONE=1.0D0)
26538 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26539 PE = EP/(GA+ONE)+EC
26543 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26549 *$ CREATE DT_DTRAFO.FOR
26552 *====dtrafo============================================================*
26554 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26555 & PL,CXL,CYL,CZL,EL)
26557 C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26559 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26562 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26563 SID = SQRT(1.D0-COD*COD)
26567 PLZ = GAM*PCMZ+BGAM*ECM
26568 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26569 EL = GAM*ECM+BGAM*PCMZ
26570 C ROTATION INTO THE ORIGINAL DIRECTION
26572 SIZ = SQRT(1.D0-COZ**2)
26573 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26578 *$ CREATE DT_STTRAN.FOR
26581 *====sttran============================================================*
26583 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26585 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26587 DATA ANGLSQ/1.D-30/
26588 ************************************************************************
26589 * VERSION BY J. RANFT *
26592 * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26594 * INPUT VARIABLES: *
26595 * XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26596 * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26597 * ANGLE OF "SCATTERING" *
26598 * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26599 * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26600 * OF "SCATTERING" *
26602 * OUTPUT VARIABLES: *
26603 * X,Y,Z = NEW DIRECTION COSINES *
26605 * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26606 ************************************************************************
26609 * Changed by A. Ferrari
26611 * IF (ABS(XO)-0.0001D0) 1,1,2
26612 * 1 IF (ABS(YO)-0.0001D0) 3,3,2
26615 IF ( A .LT. ANGLSQ ) THEN
26624 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26625 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26632 *$ CREATE DT_MYTRAN.FOR
26635 *===mytran=============================================================*
26637 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26639 ************************************************************************
26640 * This subroutine rotates the coordinate frame *
26641 * a) theta around y *
26642 * b) phi around z if IMODE = 1 *
26644 * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26645 * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26646 * z' 0 0 1 -sin(th) 0 cos(th) z *
26648 * and vice versa if IMODE = 0. *
26649 * This version dated 5.4.94 is based on the original version DTRAN *
26650 * by J. Ranft and is written by S. Roesler. *
26651 ************************************************************************
26653 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26655 PARAMETER ( LINP = 10 ,
26659 IF (IMODE.EQ.1) THEN
26660 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26661 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26662 Z=-SDE *XO +CDE *ZO
26664 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26666 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26671 *$ CREATE DT_LT2LAO.FOR
26674 *===lt2lab=============================================================*
26676 SUBROUTINE DT_LT2LAO
26678 ************************************************************************
26679 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26680 * for final state particles/fragments defined in nucleon-nucleon-cms *
26681 * and transforms them back to the lab. *
26682 * This version dated 16.11.95 is written by S. Roesler *
26683 ************************************************************************
26685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26687 PARAMETER ( LINP = 10 ,
26692 PARAMETER (NMXHKK=200000)
26693 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26694 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26695 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26696 * extended event history
26697 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26698 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26703 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26704 DO 1 I=NPOINT(4),NEND
26706 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26707 & (ISTHKK(I).EQ.1001)) THEN
26708 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26710 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26711 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26712 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26713 ISTHKK(I) = 3*ISTHKK(I)
26716 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26717 ISTHKK(I) = SIGN(3,ISTHKK(I))
26726 *$ CREATE DT_LT2LAB.FOR
26729 *===lt2lab=============================================================*
26731 SUBROUTINE DT_LT2LAB
26733 ************************************************************************
26734 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26735 * for final state particles/fragments defined in nucleon-nucleon-cms *
26736 * and transforms them to the lab. *
26737 * This version dated 07.01.96 is written by S. Roesler *
26738 ************************************************************************
26740 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26742 PARAMETER ( LINP = 10 ,
26747 PARAMETER (NMXHKK=200000)
26748 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26749 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26750 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26751 * extended event history
26752 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26753 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26756 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26757 DO 1 I=NPOINT(4),NHKK
26758 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26759 & (ISTHKK(I).EQ.1001)) THEN
26760 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26769 ************************************************************************
26771 * 5) Sampling from distributions *
26773 ************************************************************************
26774 *$ CREATE IDT_NPOISS.FOR
26777 *===npoiss=============================================================*
26779 INTEGER FUNCTION IDT_NPOISS(AVN)
26781 ************************************************************************
26782 * Sample according to Poisson distribution with Poisson parameter AVN. *
26783 * The original version written by J. Ranft. *
26784 * This version dated 11.1.95 is written by S. Roesler. *
26785 ************************************************************************
26787 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26789 PARAMETER ( LINP = 10 ,
26799 IF (A.GE.EXPAVN) THEN
26808 *$ CREATE DT_SAMPXB.FOR
26811 *===sampxb=============================================================*
26813 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26815 ************************************************************************
26816 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26817 * Processed by S. Roesler, 6.5.95 *
26818 ************************************************************************
26820 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26822 PARAMETER (TWO=2.0D0)
26824 A1 = LOG(X1+SQRT(X1**2+B**2))
26825 A2 = LOG(X2+SQRT(X2**2+B**2))
26827 A = AN*DT_RNDM(A1)+A1
26829 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26834 *$ CREATE DT_SAMPEX.FOR
26837 *===sampex=============================================================*
26839 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26841 ************************************************************************
26842 * Sampling from f(x)=1./x between x1 and x2. *
26843 * Processed by S. Roesler, 6.5.95 *
26844 ************************************************************************
26846 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26848 PARAMETER (ONE=1.0D0)
26853 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26858 *$ CREATE DT_SAMSQX.FOR
26861 *===samsqx=============================================================*
26863 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26865 ************************************************************************
26866 * Sampling from f(x)=1./x^0.5 between x1 and x2. *
26867 * Processed by S. Roesler, 6.5.95 *
26868 ************************************************************************
26870 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26872 PARAMETER (ONE=1.0D0)
26875 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26880 *$ CREATE DT_SAMPLW.FOR
26883 *===samplw=============================================================*
26885 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26887 ************************************************************************
26888 * Sampling from f(x)=1/x^b between x_min and x_max. *
26889 * S. Roesler, 18.4.98 *
26890 ************************************************************************
26892 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26894 PARAMETER (ONE=1.0D0)
26898 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26901 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26907 *$ CREATE DT_BETREJ.FOR
26910 *===betrej=============================================================*
26912 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26914 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26917 PARAMETER ( LINP = 10 ,
26920 PARAMETER (ONE=1.0D0)
26922 IF (XMIN.GE.XMAX)THEN
26923 WRITE (LOUT,500) XMIN,XMAX
26924 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26929 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26930 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26931 YY = BETMAX*DT_RNDM(XX)
26932 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26933 IF (YY.GT.BETXX) GOTO 10
26939 *$ CREATE DT_DGAMRN.FOR
26942 *===dgamrn=============================================================*
26944 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26946 ************************************************************************
26947 * Sampling from Gamma-distribution. *
26948 * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26949 * Processed by S. Roesler, 6.5.95 *
26950 ************************************************************************
26952 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26954 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26959 IF (F.EQ.ZERO) GOTO 20
26962 IF (NCOU.GE.11) GOTO 20
26963 IF (R.LT.F/(F+2.71828D0)) GOTO 30
26964 YYY = LOG(DT_RNDM(R)+TINY9)/F
26965 IF (ABS(YYY).GT.50.0D0) GOTO 20
26967 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26971 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26972 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26973 40 IF (N.EQ.0) GOTO 70
26976 60 Z = Z*DT_RNDM(Z)
26978 70 DT_DGAMRN = Y/ALAM
26983 *$ CREATE DT_DBETAR.FOR
26986 *===dbetar=============================================================*
26988 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26990 ************************************************************************
26991 * Sampling from Beta -distribution between 0.0 and 1.0 *
26992 * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26993 * Processed by S. Roesler, 6.5.95 *
26994 ************************************************************************
26996 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26999 Y = DT_DGAMRN(1.0D0,GAM)
27000 Z = DT_DGAMRN(1.0D0,ETA)
27001 DT_DBETAR = Y/(Y+Z)
27006 *$ CREATE DT_RANNOR.FOR
27009 *===rannor=============================================================*
27011 SUBROUTINE DT_RANNOR(X,Y)
27013 ************************************************************************
27014 * Sampling from Gaussian distribution. *
27015 * Processed by S. Roesler, 6.5.95 *
27016 ************************************************************************
27018 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27020 PARAMETER (TINY10=1.0D-10)
27022 CALL DT_DSFECF(SFE,CFE)
27023 V = MAX(TINY10,DT_RNDM(X))
27024 A = SQRT(-2.D0*LOG(V))
27031 *$ CREATE DT_DPOLI.FOR
27034 *===dpoli==============================================================*
27036 SUBROUTINE DT_DPOLI(CS,SI)
27038 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27043 IF (U.LT.0.5D0) CS=-CS
27044 SI = SQRT(1.0D0-CS*CS+1.0D-10)
27049 *$ CREATE DT_DSFECF.FOR
27052 *===dsfecf=============================================================*
27054 SUBROUTINE DT_DSFECF(SFE,CFE)
27056 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27058 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27066 IF (XY.GT.ONE) GOTO 1
27069 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27073 *$ CREATE DT_RACO.FOR
27076 *===raco===============================================================*
27078 SUBROUTINE DT_RACO(WX,WY,WZ)
27080 ************************************************************************
27081 * Direction cosines of random uniform (isotropic) direction in three *
27082 * dimensional space *
27083 * Processed by S. Roesler, 20.11.95 *
27084 ************************************************************************
27086 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27088 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27091 X = TWO*DT_RNDM(WX)-ONE
27095 IF (X2+Y2.GT.ONE) GOTO 10
27097 CFE = (X2-Y2)/(X2+Y2)
27098 SFE = TWO*X*Y/(X2+Y2)
27099 * z = 1/2 [ 1 + cos (theta) ]
27102 WZ = SQRT(Z*(ONE-Z))
27110 ************************************************************************
27112 * 6) Special functions, algorithms and service routines *
27114 ************************************************************************
27115 *$ CREATE DT_YLAMB.FOR
27118 *===ylamb==============================================================*
27120 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27122 ************************************************************************
27124 * auxiliary function for three particle decay mode *
27125 * (standard LAMBDA**(1/2) function) *
27127 * Adopted from an original version written by R. Engel. *
27128 * This version dated 12.12.94 is written by S. Roesler. *
27129 ************************************************************************
27131 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27135 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27136 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27137 DT_YLAMB = SQRT(XLAM)
27142 *$ CREATE DT_SORT.FOR
27145 *===sort1==============================================================*
27147 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27149 ************************************************************************
27150 * This subroutine sorts entries in A in increasing/decreasing order *
27152 * MODE = 1 increasing in A(3,i=1..N) *
27153 * = 2 decreasing in A(3,i=1..N) *
27154 * This version dated 21.04.95 is revised by S. Roesler *
27155 ************************************************************************
27157 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27169 IF (MODE.EQ.1) THEN
27170 IF (A(3,I).LE.A(3,J)) GOTO 20
27172 IF (A(3,I).GE.A(3,J)) GOTO 20
27185 IF (L.EQ.1) GOTO 10
27190 *$ CREATE DT_SORT1.FOR
27193 *===sort1==============================================================*
27195 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27197 ************************************************************************
27198 * This subroutine sorts entries in A in increasing/decreasing order *
27200 * MODE = 1 increasing in A(i=1..N) *
27201 * = 2 decreasing in A(i=1..N) *
27202 * This version dated 21.04.95 is revised by S. Roesler *
27203 ************************************************************************
27205 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27208 DIMENSION A(N),IDX(N)
27217 IF (MODE.EQ.1) THEN
27218 IF (A(I).LE.A(J)) GOTO 20
27220 IF (A(I).GE.A(J)) GOTO 20
27230 IF (L.EQ.1) GOTO 10
27235 *$ CREATE DT_XTIME.FOR
27238 *===xtime==============================================================*
27240 SUBROUTINE DT_XTIME
27242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27244 PARAMETER ( LINP = 10 ,
27248 CHARACTER DAT*9,TIM*11
27252 C CALL GETDAT(IYEAR,IMONTH,IDAY)
27253 C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27257 C WRITE(LOUT,1000) DAT,TIM
27258 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27263 ************************************************************************
27265 * 7) Random number generator package *
27267 * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
27268 * SERVICE ROUTINES. *
27269 * THE ALGORITHM IS FROM *
27270 * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27271 * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27272 * IMPLEMENTATION BY K. HAHN DEC. 88, *
27273 * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27274 * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27275 * THE PERIOD IS ABOUT 2**144, *
27276 * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27277 * THE PACKAGE CONTAINS *
27278 * FUNCTION DT_RNDM(I) : GENERATOR *
27279 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27280 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27281 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27282 * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27284 * FUNCTION DT_RNDM(I) *
27285 * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27286 * I - DUMMY VARIABLE, NOT USED *
27287 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27288 * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27289 * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27290 * NA? MUST BE IN 1..178 AND NOT ALL 1 *
27291 * 12,34,56 ARE THE STANDARD VALUES *
27292 * NB1 MUST BE IN 1..168 *
27293 * 78 IS THE STANDARD VALUE *
27294 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27295 * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27296 * AS AFTER THE LAST DT_RNDMOU CALL ) *
27297 * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27298 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27299 * TAKES SEED FROM GENERATOR *
27300 * U(97),C,CD,CM,I,J - SEED VALUES *
27301 * SUBROUTINE DT_RNDMTE(IO) *
27302 * TEST OF THE GENERATOR *
27303 * IO - DEFINES OUTPUT *
27304 * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27305 * = 1 OUTPUT INDEPENDEND ON AN ERROR *
27306 * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27308 * AS BEFORE CALL OF DT_RNDMTE *
27309 ************************************************************************
27310 *$ CREATE DT_RNDM.FOR
27313 *===rndm===============================================================*
27315 DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27317 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27320 * random number generator
27321 COMMON /DTRAND/ U(97),C,CD,CM,I,J
27323 * counter of calls to random number generator
27324 * uncomment if needed
27325 C COMMON /DTRNCT/ IRNCT0,IRNCT1
27327 C DATA LFIRST /.TRUE./
27329 * counter of calls to random number generator
27330 * uncomment if needed
27337 DT_RNDM = U(I)-U(J)
27338 IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27341 IF ( I.EQ.0 ) I = 97
27343 IF ( J.EQ.0 ) J = 97
27345 IF ( C.LT.0.0D0 ) C = C+CM
27346 DT_RNDM = DT_RNDM-C
27347 IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27349 IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27351 * counter of calls to random number generator
27352 * uncomment if needed
27353 C IRNCT0 = IRNCT0+1
27358 *$ CREATE DT_RNDMST.FOR
27361 *===rndmst=============================================================*
27363 SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27365 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27368 * random number generator
27369 COMMON /DTRAND/ U(97),C,CD,CM,I,J
27381 MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27385 MB1 = MOD(53*MB1+1,169)
27386 IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27389 C = 362436.0D0/16777216.0D0
27390 CD = 7654321.0D0/16777216.0D0
27391 CM = 16777213.0D0/16777216.0D0
27395 *$ CREATE DT_RNDMIN.FOR
27398 *===rndmin=============================================================*
27400 SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27402 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27405 * random number generator
27406 COMMON /DTRAND/ U(97),C,CD,CM,I,J
27411 10 U(KKK) = UIN(KKK)
27421 *$ CREATE DT_RNDMOU.FOR
27424 *===rndmou=============================================================*
27426 SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27428 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27431 * random number generator
27432 COMMON /DTRAND/ U(97),C,CD,CM,I,J
27437 10 UOUT(KKK) = U(KKK)
27447 *$ CREATE DT_RNDMTE.FOR
27450 *===rndmte=============================================================*
27452 SUBROUTINE DT_RNDMTE(IO)
27454 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27457 DIMENSION UU(97),U(6),X(6),D(6)
27458 DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27459 +8354498.D0, 10633180.D0/
27461 CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27462 CALL DT_RNDMST(12,34,56,78)
27463 DO 10 II1 = 1,20000
27464 10 XX = DT_RNDM(XX)
27467 X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27468 D(II2) = X(II2)-U(II2)
27470 CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27472 C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27473 IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27475 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27480 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27481 &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27482 &1,F20.1,F15.3,/), ' === END OF TEST ;',
27483 &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27486 *$ CREATE PHO_RNDM.FOR
27489 *===pho_rndm===========================================================*
27491 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27493 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27496 PHO_RNDM = DT_RNDM(DUMMY)
27504 *===pyr================================================================*
27506 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27508 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27511 DUMMY = DBLE(IDUMMY)
27512 PYR = DT_RNDM(DUMMY)
27517 *$ CREATE DT_TITLE.FOR
27520 *===title==============================================================*
27522 SUBROUTINE DT_TITLE
27524 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27526 PARAMETER ( LINP = 10 ,
27531 CHARACTER*11 CCHANG
27532 DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27535 WRITE(LOUT,1000) CVERSI,CCHANG
27536 1000 FORMAT(1X,'+-------------------------------------------------',
27537 & '----------------------+',/,
27538 & 1X,'|',71X,'|',/,
27539 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27540 & 1X,'|',71X,'|',/,
27541 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27542 & 1X,'|',71X,'|',/,
27543 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27544 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27545 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27546 & 1X,'|',71X,'|',/,
27547 & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27549 & 1X,'|',71X,'|',/,
27550 & 1X,'+-------------------------------------------------',
27551 & '----------------------+',/,
27552 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27553 & 'Stefan.Roesler@cern.ch |',/,
27554 & 1X,'+-------------------------------------------------',
27555 & '----------------------+',/)
27560 *$ CREATE DT_EVTINI.FOR
27563 *===evtini=============================================================*
27565 SUBROUTINE DT_EVTINI
27567 ************************************************************************
27568 * Initialization of DTEVT1. *
27569 * This version dated 15.01.94 is written by S. Roesler *
27570 ************************************************************************
27572 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27574 PARAMETER ( LINP = 10 ,
27579 PARAMETER (NMXHKK=200000)
27580 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27581 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27582 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27583 * extended event history
27584 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27585 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27588 COMMON /DTEVNO/ NEVENT,ICASCA
27589 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27590 * emulsion treatment
27591 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27594 * initialization of DTEVT1/DTEVT2
27596 IF (NEVENT.EQ.1) NEND = NMXHKK
27624 C* initialization of DTLTRA
27625 C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27630 *$ CREATE DT_STATIS.FOR
27633 *===statis=============================================================*
27635 SUBROUTINE DT_STATIS(MODE)
27637 ************************************************************************
27638 * Initialization and output of run-statistics. *
27639 * MODE = 1 initialization *
27641 * This version dated 23.01.94 is written by S. Roesler *
27642 ************************************************************************
27644 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27646 PARAMETER ( LINP = 10 ,
27649 PARAMETER (TINY3=1.0D-3)
27652 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27653 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27655 * rejection counter
27656 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27657 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27658 & IREXCI(3),IRDIFF(2),IRINC
27659 * central particle production, impact parameter biasing
27660 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27661 * various options for treatment of partons (DTUNUC 1.x)
27662 * (chain recombination, Cronin,..)
27663 LOGICAL LCO2CR,LINTPT
27664 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27666 * nucleon-nucleon event-generator
27669 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27670 * flags for particle decays
27671 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27672 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27673 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27674 * diquark-breaking mechanism
27675 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27677 DIMENSION PP(4),PT(4)
27684 * initialize statistics counter
27697 * initialize rejection counter
27728 * statistics counter
27730 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27731 & 28X,'---------------------')
27732 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27733 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27734 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27735 & 'event',11X,F9.1)
27736 IF (ICDIFF(1).NE.0) THEN
27737 WRITE(LOUT,1009) ICDIFF
27738 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27739 & 'low mass high mass',/,24X,'single diffraction',
27740 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27742 IF (ICENTR.GT.0) THEN
27743 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27744 & DBLE(ICSAMP)/DBLE(ICCPRO)
27745 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27746 & ' of sampled Glauber-events per event',9X,F9.1,/,
27747 & 2X,'fraction of production cross section',21X,F10.6)
27749 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27750 & DBLE(ICDTA)/DBLE(ICSAMP)
27751 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27752 & ' nucleons after x-sampling',2(4X,F6.2))
27754 IF (MCGENE.EQ.1) THEN
27755 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27756 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27757 & ' event',3X,F9.1)
27758 IF (ISICHA.EQ.1) THEN
27759 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27760 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27761 & 'of single chains per event',13X,F9.1)
27764 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27765 & 23X,'mean number of chains mean number of chains',/,
27766 & 23X,'sampled hadronized having mass of a reso.')
27767 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27768 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27769 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27770 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27771 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27772 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27773 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27774 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27775 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27776 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27777 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27778 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27779 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27781 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27782 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27783 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27784 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27785 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27786 & DBLE(IRHHA)/DBLE(ICREQU),
27787 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27788 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27789 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27790 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27791 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27792 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27793 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27794 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27795 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27796 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27797 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27798 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27799 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27800 & F7.2,/,1X,'Total no. of rej.',
27801 & ' in chain-systems treatment (GETCSY)',/,43X,
27802 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27803 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27804 & 1X,'Total no. of rej. in DPM-treatment of one event',
27805 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27806 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27807 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27808 & 'IREXCI(3) = ',I5,/)
27809 ELSEIF (MCGENE.EQ.2) THEN
27810 WRITE(LOUT,1010) ELOJET
27811 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27814 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27815 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27816 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27817 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27818 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27819 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27820 & ((ICEVTG(I,J),I=1,8),J=3,7),
27821 & ((ICEVTG(I,J),I=1,8),J=19,21),
27822 & (ICEVTG(I,8),I=1,8),
27823 & ((ICEVTG(I,J),I=1,8),J=22,24),
27824 & (ICEVTG(I,9),I=1,8),
27825 & ((ICEVTG(I,J),I=1,8),J=25,28),
27826 & ((ICEVTG(I,J),I=1,8),J=10,18)
27827 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27828 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27829 & ' no-dif.',8I8,/,
27830 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27831 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27832 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27833 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27834 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27836 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27837 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27838 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27840 1013 FORMAT(/,1X,'2. chain system statistics -',
27841 & ' mean numbers per evt:',/,30X,'---------------------',
27842 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27844 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27845 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27846 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27847 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27848 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27849 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27850 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27851 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27852 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27853 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27854 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27855 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27856 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
27858 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27860 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27861 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27862 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27863 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27864 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27865 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27866 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27867 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27868 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27869 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27870 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27871 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27872 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
27877 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27878 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27879 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27880 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27881 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27882 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27883 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27884 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27885 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27886 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27887 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27888 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27889 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27890 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27891 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27892 & DBRKA(3,1),DBRKA(3,2),
27893 & DBRKA(3,3),DBRKA(3,4)
27894 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27895 & DBRKR(3,1),DBRKR(3,2),
27896 & DBRKR(3,3),DBRKR(3,4)
27897 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27898 & DBRKA(3,5),DBRKA(3,6),
27899 & DBRKA(3,7),DBRKA(3,8)
27900 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27901 & DBRKR(3,5),DBRKR(3,6),
27902 & DBRKR(3,7),DBRKR(3,8)
27906 IF (MCGENE.EQ.2) THEN
27907 C CALL PHO_PHIST(-2,SIGMAX)
27908 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27916 *$ CREATE DT_EVTOUT.FOR
27919 *===evtout=============================================================*
27921 SUBROUTINE DT_EVTOUT(MODE)
27923 ************************************************************************
27924 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27925 * 3 plot entries of extended DTEVT1 (DTEVT2) *
27926 * 4 plot entries of DTEVT1 and DTEVT2 *
27927 * This version dated 11.12.94 is written by S. Roesler *
27928 ************************************************************************
27930 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27932 PARAMETER ( LINP = 10 ,
27936 PARAMETER (NMXHKK=200000)
27937 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27938 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27939 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27941 DIMENSION IRANGE(NMXHKK)
27943 IF (MODE.EQ.2) RETURN
27945 CALL DT_EVTPLO(IRANGE,MODE)
27950 *$ CREATE DT_EVTPLO.FOR
27953 *===evtplo=============================================================*
27955 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27957 ************************************************************************
27958 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27959 * 2 plot entries of DTEVT1 given by IRANGE *
27960 * 3 plot entries of extended DTEVT1 (DTEVT2) *
27961 * 4 plot entries of DTEVT1 and DTEVT2 *
27962 * 5 plot rejection counter *
27963 * This version dated 11.12.94 is written by S. Roesler *
27964 ************************************************************************
27966 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27968 PARAMETER ( LINP = 10 ,
27975 PARAMETER (NMXHKK=200000)
27976 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27977 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27978 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27979 * extended event history
27980 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27981 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27983 * rejection counter
27984 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27985 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27986 & IREXCI(3),IRDIFF(2),IRINC
27988 DIMENSION IRANGE(NMXHKK)
27990 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27992 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
27993 & 15X,' --------------------------',/,/,
27994 & ' ST ID M1 M2 D1 D2 PX PY',
27997 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27998 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27999 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28001 C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28002 C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28003 C & PHKK(3,I),PHKK(4,I)
28004 C WRITE(LOUT,'(4E15.4)')
28005 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28006 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28007 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
28011 C WRITE(LOUT,1006) I,ISTHKK(I),
28012 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28013 C & WHKK(2,I),WHKK(3,I)
28014 C1006 FORMAT(1X,I4,I6,6E10.3)
28018 IF (MODE.EQ.2) THEN
28023 IF (IRANGE(NC).EQ.-100) GOTO 9999
28025 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28026 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28027 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28032 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28034 1002 FORMAT(/,1X,'EVTPLO:',14X,
28035 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28036 & 15X,' -----------------------------------',/,/,
28037 & ' ST ID M1 M2 D1 D2 IDR IDXR',
28038 & ' NOBAM IDCH M',/)
28040 C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28043 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28044 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28045 CALL PYNAME(KF,CHAU)
28046 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28047 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28048 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28050 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28055 IF (MODE.EQ.5) THEN
28057 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
28058 & 15X,' --------------------------',/)
28059 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28061 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
28062 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
28063 & 1X,'IREMC = ',10I5,/,
28064 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
28070 *$ CREATE DT_EVTPUT.FOR
28073 *===evtput=============================================================*
28075 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28077 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28079 PARAMETER ( LINP = 10 ,
28082 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28083 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28086 PARAMETER (NMXHKK=200000)
28087 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28088 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28089 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28090 * extended event history
28091 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28092 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28094 * Lorentz-parameters of the current interaction
28095 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28096 & UMO,PPCM,EPROJ,PPROJ
28097 * particle properties (BAMJET index convention)
28099 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28100 & IICH(210),IIBAR(210),K1(210),K2(210)
28102 C IF (MODE.GT.100) THEN
28103 C WRITE(LOUT,'(1X,A,I5,A,I5)')
28104 C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28105 C NHKK = NHKK-MODE+100
28112 IF (NHKK.GT.NMXHKK) THEN
28113 WRITE(LOUT,1000) NHKK
28114 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28115 & '! program execution stopped..')
28118 IF (M1.LT.0) MO1 = NHKK+M1
28119 IF (M2.LT.0) MO2 = NHKK+M2
28122 JMOHKK(1,NHKK) = MO1
28123 JMOHKK(2,NHKK) = MO2
28127 IDXRES(NHKK) = IDXR
28129 ** here we need to do something..
28130 IF (ID.EQ.88888) THEN
28131 IDMO1 = ABS(IDHKK(MO1))
28132 IDMO2 = ABS(IDHKK(MO2))
28133 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28134 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28135 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28136 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28140 IDBAM(NHKK) = IDT_ICIHAD(ID)
28142 IF (JDAHKK(1,MO1).NE.0) THEN
28143 JDAHKK(2,MO1) = NHKK
28145 JDAHKK(1,MO1) = NHKK
28149 IF (JDAHKK(1,MO2).NE.0) THEN
28150 JDAHKK(2,MO2) = NHKK
28152 JDAHKK(1,MO2) = NHKK
28155 C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28156 C PTOT = SQRT(PX**2+PY**2+PZ**2)
28157 C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28158 C AMRQ = AAM(IDBAM(NHKK))
28159 C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28160 C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28161 C & (PTOT.GT.ZERO)) THEN
28162 C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28163 CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28165 C PTOT1 = PTOT-DELTA
28166 C PX = PX*PTOT1/PTOT
28167 C PY = PY*PTOT1/PTOT
28168 C PZ = PZ*PTOT1/PTOT
28175 PTOT = SQRT( PX**2+PY**2+PZ**2 )
28176 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28177 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28178 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28180 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28181 C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28182 C & WRITE(LOUT,'(1X,A,G10.3)')
28183 C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28184 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28187 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28188 * special treatment for chains:
28189 * z coordinate of chain in Lab = pos. of target nucleon
28190 * time of chain-creation in Lab = time of passage of projectile
28191 * nucleus at pos. of taget nucleus
28192 C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28193 C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28194 VHKK(1,NHKK) = VHKK(1,MO2)
28195 VHKK(2,NHKK) = VHKK(2,MO2)
28196 VHKK(3,NHKK) = VHKK(3,MO2)
28197 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28198 C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28199 C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28200 WHKK(1,NHKK) = WHKK(1,MO1)
28201 WHKK(2,NHKK) = WHKK(2,MO1)
28202 WHKK(3,NHKK) = WHKK(3,MO1)
28203 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28207 VHKK(I,NHKK) = VHKK(I,MO1)
28208 WHKK(I,NHKK) = WHKK(I,MO1)
28212 VHKK(I,NHKK) = ZERO
28213 WHKK(I,NHKK) = ZERO
28221 *$ CREATE DT_CHASTA.FOR
28224 *===chasta=============================================================*
28226 SUBROUTINE DT_CHASTA(MODE)
28228 ************************************************************************
28229 * This subroutine performs CHAin STAtistics and checks sequence of *
28230 * partons in dtevt1 and sorts them with projectile partons coming *
28231 * first if necessary. *
28233 * This version dated 8.5.00 is written by S. Roesler. *
28234 ************************************************************************
28236 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28238 PARAMETER ( LINP = 10 ,
28245 PARAMETER (NMXHKK=200000)
28246 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28247 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28248 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28249 * extended event history
28250 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28251 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28253 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28254 PARAMETER (MAXCHN=10000)
28255 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28257 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28258 & CCHTYP(9),ICHSTA(10),ITOT(10)
28259 DATA ICHCFG /1800*0/
28260 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28261 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28262 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28263 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28264 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28265 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28266 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28267 & 'ad aq',' d ad','ad d ',' g g '/
28271 IF (MODE.EQ.-1) THEN
28274 * loop over DTEVT1 and analyse chain configurations
28276 ELSEIF (MODE.EQ.0) THEN
28277 DO 21 IDX=NPOINT(3),NHKK
28278 IDCHK = IDHKK(IDX)/10000
28279 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28280 & (IDHKK(IDX).NE.80000).AND.
28281 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28282 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28283 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28288 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28289 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28291 IMO1 = IST1-10*IMO1
28293 IMO2 = IST2-10*IMO2
28294 * swop parton entries if necessary since we need projectile partons
28295 * to come first in the common
28296 IF (IMO1.GT.IMO2) THEN
28297 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28299 I0 = JMOHKK(1,IDX)-1+K
28300 I1 = JMOHKK(2,IDX)+1-K
28302 ISTHKK(I0) = ISTHKK(I1)
28305 IDHKK(I0) = IDHKK(I1)
28307 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28308 & JDAHKK(1,JMOHKK(1,I0)) = I1
28309 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28310 & JDAHKK(2,JMOHKK(1,I0)) = I1
28311 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28312 & JDAHKK(1,JMOHKK(2,I0)) = I1
28313 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28314 & JDAHKK(2,JMOHKK(2,I0)) = I1
28315 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28316 & JDAHKK(1,JMOHKK(1,I1)) = I0
28317 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28318 & JDAHKK(2,JMOHKK(1,I1)) = I0
28319 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28320 & JDAHKK(1,JMOHKK(2,I1)) = I0
28321 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28322 & JDAHKK(2,JMOHKK(2,I1)) = I0
28323 ITMP = JMOHKK(1,I0)
28324 JMOHKK(1,I0) = JMOHKK(1,I1)
28325 JMOHKK(1,I1) = ITMP
28326 ITMP = JMOHKK(2,I0)
28327 JMOHKK(2,I0) = JMOHKK(2,I1)
28328 JMOHKK(2,I1) = ITMP
28329 ITMP = JDAHKK(1,I0)
28330 JDAHKK(1,I0) = JDAHKK(1,I1)
28331 JDAHKK(1,I1) = ITMP
28332 ITMP = JDAHKK(2,I0)
28333 JDAHKK(2,I0) = JDAHKK(2,I1)
28334 JDAHKK(2,I1) = ITMP
28339 PHKK(J,I0) = PHKK(J,I1)
28340 VHKK(J,I0) = VHKK(J,I1)
28341 WHKK(J,I0) = WHKK(J,I1)
28347 PHKK(5,I0) = PHKK(5,I1)
28350 IDRES(I0) = IDRES(I1)
28353 IDXRES(I0) = IDXRES(I1)
28356 NOBAM(I0) = NOBAM(I1)
28359 IDBAM(I0) = IDBAM(I1)
28362 IDCH(I0) = IDCH(I1)
28365 IHIST(1,I0) = IHIST(1,I1)
28368 IHIST(2,I0) = IHIST(2,I1)
28372 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28373 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28375 * parton 1 (projectile side)
28376 IF (IST1.EQ.21) THEN
28378 ELSEIF (IST1.EQ.22) THEN
28380 ELSEIF (IST1.EQ.31) THEN
28382 ELSEIF (IST1.EQ.32) THEN
28384 ELSEIF (IST1.EQ.41) THEN
28386 ELSEIF (IST1.EQ.42) THEN
28388 ELSEIF (IST1.EQ.51) THEN
28390 ELSEIF (IST1.EQ.52) THEN
28392 ELSEIF (IST1.EQ.61) THEN
28394 ELSEIF (IST1.EQ.62) THEN
28398 c & ' CHASTA: unknown parton status flag (',
28399 c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28402 ID = IDHKK(JMOHKK(1,IDX))
28403 IF (ABS(ID).LE.4) THEN
28409 ELSEIF (ABS(ID).GE.1000) THEN
28415 ELSEIF (ID.EQ.21) THEN
28419 & ' CHASTA: inconsistent parton identity (',
28420 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28424 * parton 2 (target side)
28425 IF (IST2.EQ.21) THEN
28427 ELSEIF (IST2.EQ.22) THEN
28429 ELSEIF (IST2.EQ.31) THEN
28431 ELSEIF (IST2.EQ.32) THEN
28433 ELSEIF (IST2.EQ.41) THEN
28435 ELSEIF (IST2.EQ.42) THEN
28437 ELSEIF (IST2.EQ.51) THEN
28439 ELSEIF (IST2.EQ.52) THEN
28441 ELSEIF (IST2.EQ.61) THEN
28443 ELSEIF (IST2.EQ.62) THEN
28447 c & ' CHASTA: unknown parton status flag (',
28448 c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28451 ID = IDHKK(JMOHKK(2,IDX))
28452 IF (ABS(ID).LE.4) THEN
28458 ELSEIF (ABS(ID).GE.1000) THEN
28464 ELSEIF (ID.EQ.21) THEN
28468 & ' CHASTA: inconsistent parton identity (',
28469 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28474 ITYPE = ICHTYP(ITYP1,ITYP2)
28475 IF (ITYPE.NE.0) THEN
28476 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28477 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28478 ICHCFG(IDX1,IDX2,ITYPE,2) =
28479 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28482 IF (NCHAIN.GT.MAXCHN) THEN
28483 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28487 IDXCHN(1,NCHAIN) = IDX
28488 IDXCHN(2,NCHAIN) = ITYPE
28491 & ' CHASTA: inconsistent chain at entry ',IDX
28497 * write statistics to output unit
28499 ELSEIF (MODE.EQ.1) THEN
28500 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28502 WRITE(LOUT,'(/,2A)')
28503 & ' -----------------------------------------',
28504 & '------------------------------------'
28506 & ' p\\t 21 22 31 32 41',
28507 & ' 42 51 52 61 62'
28509 & ' -----------------------------------------',
28510 & '------------------------------------'
28514 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28517 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28521 ISUM = ISUM+ICHCFG(I,J,K,1)
28524 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28525 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28527 C WRITE(LOUT,'(2A)')
28528 C & ' -----------------------------------------',
28529 C & '-------------------------------'
28533 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28539 *$ CREATE PHO_PHIST.FOR
28542 *===pohist=============================================================*
28544 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28546 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28549 PARAMETER ( LINP = 10 ,
28552 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28553 * Glauber formalism: cross sections
28554 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28555 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28556 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28557 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28558 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28559 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28560 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28561 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28562 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28563 & BSLOPE,NEBINI,NQBINI
28566 IF (IMODE.EQ.10) THEN
28570 IF (ABS(IMODE).LT.1000) THEN
28571 * PHOJET-statistics
28572 C CALL POHISX(IMODE,WEIGHT)
28573 IF (IMODE.EQ.-1) THEN
28575 XSTOT(1,1,1) = WEIGHT
28577 IF (IMODE.EQ. 1) MODE = 2
28578 IF (IMODE.EQ.-2) MODE = 3
28579 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28580 C IF (MODE.EQ.3) WRITE(LOUT,*)
28581 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28582 CALL DT_HISTOG(MODE)
28583 CALL DT_USRHIS(MODE)
28585 * DTUNUC-statistics
28587 C IF (MODE.EQ.3) WRITE(LOUT,*)
28588 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28589 CALL DT_HISTOG(MODE)
28590 CALL DT_USRHIS(MODE)
28596 *$ CREATE DT_SWPPHO.FOR
28599 *===swppho=============================================================*
28601 SUBROUTINE DT_SWPPHO(ILAB)
28603 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28605 PARAMETER ( LINP = 10 ,
28608 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28613 PARAMETER (NMXHKK=200000)
28614 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28615 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28616 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28617 * extended event history
28618 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28619 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28621 * flags for input different options
28622 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28623 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28624 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28625 * properties of photon/lepton projectiles
28626 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28629 C PARAMETER (NMXHEP=2000)
28630 C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28631 C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28632 C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28633 C COMMON /PLASAV/ PLAB
28635 C standard particle data interface
28637 PARAMETER (NMXHEP=4000)
28638 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28639 DOUBLE PRECISION PHEP,VHEP
28640 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28641 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28643 C extension to standard particle data interface (PHOJET specific)
28644 INTEGER IMPART,IPHIST,ICOLOR
28645 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28646 C global event kinematics and particle IDs
28647 INTEGER IFPAP,IFPAB
28648 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28649 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28653 DATA LSTART /.TRUE./
28655 C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28656 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28660 IDP = IDT_ICIHAD(IFPAP(1))
28661 IDT = IDT_ICIHAD(IFPAP(2))
28663 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28672 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28674 IF (ISTHEP(I).EQ.1) THEN
28677 IDHKK(NHKK) = IDHEP(I)
28683 PHKK(K,NHKK) = PHEP(K,I)
28684 VHKK(K,NHKK) = ZERO
28685 WHKK(K,NHKK) = ZERO
28687 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28688 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28689 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28690 PHKK(5,NHKK) = PHEP(5,I)
28694 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28702 *$ CREATE DT_HISTOG.FOR
28705 *===histog=============================================================*
28707 SUBROUTINE DT_HISTOG(MODE)
28709 ************************************************************************
28710 * This version dated 25.03.96 is written by S. Roesler *
28711 ************************************************************************
28713 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28715 PARAMETER ( LINP = 10 ,
28722 PARAMETER (NMXHKK=200000)
28723 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28724 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28725 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28726 * extended event history
28727 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28728 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28730 * event flag used for histograms
28731 COMMON /DTNORM/ ICEVT,IEVHKK
28732 * flags for activated histograms
28733 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28738 *------------------------------------------------------------------
28742 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28743 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28746 *------------------------------------------------------------------
28747 * filling of histogram with event-record
28752 CALL DT_SWPFSP(I,LFSP,LRNL)
28754 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28755 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28757 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28759 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28762 *------------------------------------------------------------------
28765 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28766 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28771 *$ CREATE DT_SWPFSP.FOR
28774 *===swpfsp=============================================================*
28776 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28778 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28780 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28781 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28783 & BOG =TWOPI/360.0D0)
28786 PARAMETER (NMXHKK=200000)
28787 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28788 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28789 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28790 * extended event history
28791 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28792 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28794 * particle properties (BAMJET index convention)
28796 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28797 & IICH(210),IIBAR(210),K1(210),K2(210)
28798 * Lorentz-parameters of the current interaction
28799 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28800 & UMO,PPCM,EPROJ,PPROJ
28801 * flags for input different options
28802 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28803 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28804 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28805 * (original name: PAREVT)
28806 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28807 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28808 PARAMETER ( NALLWP = 39 )
28809 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28810 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28811 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28812 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28813 * temporary storage for one final state particle
28814 LOGICAL LFRAG,LGREY,LBLACK
28815 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28816 & SINTHE,COSTHE,THETA,THECMS,
28817 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28818 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28819 & LFRAG,LGREY,LBLACK
28827 IF (LEVPRT) ISTRNL = 1001
28829 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28833 IF (IDHKK(IDX).LT.80000) THEN
28835 IBARY = IIBAR(IDBJT)
28836 ICHAR = IICH(IDBJT)
28838 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28841 ICHAR = IDXRES(IDX)
28842 AMASS = PHKK(5,IDX)
28844 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28845 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28846 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28847 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28848 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28858 PTOT = SQRT(PT2+PZ**2)
28859 SINTHE = PT/MAX(PTOT,TINY14)
28860 COSTHE = PZ/MAX(PTOT,TINY14)
28861 IF (COSTHE.GT.ONE) THEN
28863 ELSEIF (COSTHE.LT.-ONE) THEN
28864 THETA = TWOPI/2.0D0
28866 THETA = ACOS(COSTHE)
28869 **sr 15.4.96 new E_t-definition
28870 IF (IBARY.GT.0) THEN
28872 ELSEIF (IBARY.LT.0) THEN
28873 ET = (EKIN+TWO*AMASS)*SINTHE
28878 XLAB = PZ/MAX(PPROJ,TINY14)
28879 C XLAB = PE/MAX(EPROJ,TINY14)
28880 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28881 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28884 IF (PMINUS.GT.TINY14) THEN
28885 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28889 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28890 ETA = -LOG(TAN(THETA/TWO))
28894 IF (IFRAME.EQ.1) THEN
28895 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28896 PPLUS = EECMS+PZCMS
28897 PMINUS = EECMS-PZCMS
28898 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28899 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28903 PTOTCM = SQRT(PT2+PZCMS**2)
28904 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28905 IF (COSTH.GT.ONE) THEN
28907 ELSEIF (COSTH.LT.-ONE) THEN
28908 THECMS = TWOPI/2.0D0
28910 THECMS = ACOS(COSTH)
28912 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28913 ETACMS = -LOG(TAN(THECMS/TWO))
28917 XF = PZCMS/MAX(PPCM,TINY14)
28918 THECMS = THECMS/BOG
28929 * set flag for "grey/black"
28933 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28934 IF (MULDEF.EQ.1) THEN
28936 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28937 & (EK.LE.375.0D-3) ).OR.
28938 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28939 & (EK.LE. 56.0D-3) ).OR.
28940 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28941 & (EK.LE. 56.0D-3) ).OR.
28942 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28943 & (EK.LE.198.0D-3) ).OR.
28944 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28945 & (EK.LE.198.0D-3) ).OR.
28946 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28947 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28948 & (IDBJT.NE.16).AND.
28949 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28951 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28952 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28953 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28954 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28955 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28956 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28957 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28958 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
28962 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28963 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28966 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28972 ICHAR = IDXRES(IDX)
28973 AMASS = PHKK(5,IDX)
28980 PTOT = SQRT(PT2+PZ**2)
28981 SINTHE = PT/MAX(PTOT,TINY14)
28982 COSTHE = PZ/MAX(PTOT,TINY14)
28983 IF (COSTHE.GT.ONE) THEN
28985 ELSEIF (COSTHE.LT.-ONE) THEN
28986 THETA = TWOPI/2.0D0
28988 THETA = ACOS(COSTHE)
28991 **sr 15.4.96 new E_t-definition
28995 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28996 ETA = -LOG(TAN(THETA/TWO))
29008 *$ CREATE DT_HIMULT.FOR
29011 *===himult=============================================================*
29013 SUBROUTINE DT_HIMULT(MODE)
29015 ************************************************************************
29016 * Tables of average energies/multiplicities. *
29017 * This version dated 30.08.2000 is written by S. Roesler *
29018 ************************************************************************
29020 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29022 PARAMETER ( LINP = 10 ,
29025 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29027 PARAMETER (SWMEXP=1.7D0)
29029 CHARACTER*8 ANAMEH(4)
29031 * particle properties (BAMJET index convention)
29033 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29034 & IICH(210),IIBAR(210),K1(210),K2(210)
29035 * temporary storage for one final state particle
29036 LOGICAL LFRAG,LGREY,LBLACK
29037 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29038 & SINTHE,COSTHE,THETA,THECMS,
29039 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29040 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29041 & LFRAG,LGREY,LBLACK
29042 * event flag used for histograms
29043 COMMON /DTNORM/ ICEVT,IEVHKK
29044 * Lorentz-parameters of the current interaction
29045 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29046 & UMO,PPCM,EPROJ,PPROJ
29048 PARAMETER (NOPART=210)
29049 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29050 & AVPT(4,NOPART),IAVPT(4,NOPART)
29051 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
29055 *------------------------------------------------------------------
29070 *------------------------------------------------------------------
29071 * filling of histogram with event-record
29073 IF (PE.LT.0.0D0) THEN
29074 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
29077 IF (.NOT.LFRAG) THEN
29079 IF (LGREY) IVEL = 3
29080 IF (LBLACK) IVEL = 4
29081 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
29082 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
29083 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
29084 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
29085 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
29086 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29087 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
29088 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29089 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
29090 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29091 IF (IDBJT.LT.116) THEN
29092 * total energy, multiplicity
29093 AVE(1,30) = AVE(1,30) +PE
29094 AVE(IVEL,30) = AVE(IVEL,30)+PE
29095 AVPT(1,30) = AVPT(1,30) +PT
29096 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
29097 IAVPT(1,30) = IAVPT(1,30) +1
29098 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29099 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
29100 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
29101 AVMULT(1,30) = AVMULT(1,30) +ONE
29102 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29103 * charged energy, multiplicity
29104 IF (ICHAR.LT.0) THEN
29105 AVE(1,26) = AVE(1,26) +PE
29106 AVE(IVEL,26) = AVE(IVEL,26)+PE
29107 AVPT(1,26) = AVPT(1,26) +PT
29108 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
29109 IAVPT(1,26) = IAVPT(1,26) +1
29110 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29111 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
29112 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
29113 AVMULT(1,26) = AVMULT(1,26) +ONE
29114 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29116 IF (ICHAR.NE.0) THEN
29117 AVE(1,27) = AVE(1,27) +PE
29118 AVE(IVEL,27) = AVE(IVEL,27)+PE
29119 AVPT(1,27) = AVPT(1,27) +PT
29120 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
29121 IAVPT(1,27) = IAVPT(1,27) +1
29122 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29123 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
29124 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
29125 AVMULT(1,27) = AVMULT(1,27) +ONE
29126 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29133 *------------------------------------------------------------------
29137 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29138 & 29X,'---------------------',/)
29139 IF (MULDEF.EQ.1) THEN
29140 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29144 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29145 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
29146 & ,F4.2,' black: beta < ',F4.2,/)
29148 WRITE(LOUT,3003) SWMEXP
29149 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
29150 & 13X,'| total fast',
29151 C & ' grey black K f(',F3.1,')',/,1X,
29152 & ' grey black <pt> f(',F3.1,')',/,1X,
29153 & '------------+--------------',
29154 & '-------------------------------------------------')
29157 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29158 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29159 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29160 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29163 WRITE(LOUT,3004) ANAME(I),I,
29164 & AVMULT(1,I),AVMULT(2,I),
29165 & AVMULT(3,I),AVMULT(4,I),
29166 C & AVE(1,I),AVSWM(1,I)
29167 & AVPT(1,I),AVSWM(1,I)
29168 ELSEIF (I.LE.119) THEN
29169 WRITE(LOUT,3004) ANAMEH(I-115),I,
29170 & AVMULT(1,I),AVMULT(2,I),
29171 & AVMULT(3,I),AVMULT(4,I),
29172 C & AVE(1,I),AVSWM(1,I)
29173 & AVPT(1,I),AVSWM(1,I)
29175 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29178 C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29179 C & AVMULT(3,27)+AVMULT(4,27)
29185 *$ CREATE DT_HISTAT.FOR
29188 *===histat=============================================================*
29190 SUBROUTINE DT_HISTAT(IDX,MODE)
29192 ************************************************************************
29193 * This version dated 26.02.96 is written by S. Roesler *
29195 * Last change 27.12.2006 by S. Roesler. *
29196 ************************************************************************
29198 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29200 PARAMETER ( LINP = 10 ,
29203 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29204 PARAMETER (NDIM=199)
29207 PARAMETER (NMXHKK=200000)
29208 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29209 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29210 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29211 * extended event history
29212 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29213 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29215 * particle properties (BAMJET index convention)
29217 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29218 & IICH(210),IIBAR(210),K1(210),K2(210)
29219 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29220 * Glauber formalism: cross sections
29221 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29222 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29223 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29224 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29225 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29226 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29227 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29228 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29229 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29230 & BSLOPE,NEBINI,NQBINI
29231 * emulsion treatment
29232 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29234 * properties of interacting particles
29235 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29236 * rejection counter
29237 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29238 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29239 & IREXCI(3),IRDIFF(2),IRINC
29240 * statistics: residual nuclei
29241 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29242 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29243 & NINCST(2,4),NINCEV(2),
29244 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29245 & NRESPB(2),NRESCH(2),NRESEV(4),
29246 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29248 * parameter for intranuclear cascade
29250 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29251 * (original name: PAREVT)
29252 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29253 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29254 PARAMETER ( NALLWP = 39 )
29255 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29256 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29257 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29258 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29259 * (original name: FRBKCM)
29260 PARAMETER ( MXFFBK = 6 )
29261 PARAMETER ( MXZFBK = 9 )
29262 PARAMETER ( MXNFBK = 10 )
29263 PARAMETER ( MXAFBK = 16 )
29264 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29265 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29266 PARAMETER ( NXAFBK = MXAFBK + 1 )
29267 PARAMETER ( MXPSST = 300 )
29268 PARAMETER ( MXPSFB = 41000 )
29269 LOGICAL LFRMBK, LNCMSS
29270 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29271 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29272 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29273 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29274 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29275 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29276 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29277 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29278 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
29279 * (original name: INPFLG)
29280 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29281 * temporary storage for one final state particle
29282 LOGICAL LFRAG,LGREY,LBLACK
29283 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29284 & SINTHE,COSTHE,THETA,THECMS,
29285 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29286 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29287 & LFRAG,LGREY,LBLACK
29288 * event flag used for histograms
29289 COMMON /DTNORM/ ICEVT,IEVHKK
29290 * statistics: double-Pomeron exchange
29291 COMMON /DTFLG2/ INTFLG,IPOPO
29293 DIMENSION EMUSAM(NCOMPX)
29295 CHARACTER*13 CMSG(3)
29296 DATA CMSG /'not requested','not requested','not requested'/
29298 GOTO (1,2,3,4,5) MODE
29300 *------------------------------------------------------------------
29303 * emulsion treatment
29304 IF (NCOMPO.GT.0) THEN
29309 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29330 IF (J.LE.2) NINCHR(I,J) = 0
29331 IF (J.LE.3) NINCCO(I,J) = 0
29332 IF (J.LE.4) NINCST(I,J) = 0
29341 **dble Po statistics.
29345 *------------------------------------------------------------------
29346 * filling of histogram with event-record
29348 IF (IST.EQ.-1) THEN
29349 IF (.NOT.LFRAG) THEN
29350 IF (IDPDG.EQ.2212) THEN
29351 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29352 ELSEIF (IDPDG.EQ.2112) THEN
29353 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29354 ELSEIF (IDPDG.EQ.22) THEN
29355 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29356 ELSEIF (IDPDG.EQ.80000) THEN
29357 IF (IDBJT.EQ.116) THEN
29358 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29359 ELSEIF (IDBJT.EQ.117) THEN
29360 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29361 ELSEIF (IDBJT.EQ.118) THEN
29362 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29363 ELSEIF (IDBJT.EQ.119) THEN
29364 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29368 * heavy fragments (here: fission products only)
29369 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29370 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29371 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29373 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29374 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29378 *------------------------------------------------------------------
29382 **dble Po statistics.
29383 C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29384 C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29385 C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29387 * emulsion treatment
29388 IF (NCOMPO.GT.0) THEN
29390 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29391 & 22X,'----------------------------',/,/,19X,
29392 & 'mass charge fraction',/,39X,
29393 & 'input treated',/)
29395 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29396 & EMUSAM(I)/DBLE(ICEVT)
29397 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29401 * i.n.c. statistics: output
29402 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29403 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29404 & 22X,'---------------------------------',/,/,1X,
29405 & 'no. of events for normalization: (accepted final events,',
29406 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29407 & /,1X,'no. of rejected events due to intranuclear',
29408 & ' cascade',15X,I6,/)
29409 ICEV = MAX(ICEVT,1)
29411 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29413 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29414 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29415 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29416 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29417 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29418 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29419 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29420 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29421 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29422 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29423 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29424 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29425 & /,1X,'maximum no. of generations treated (maximum allowed:'
29426 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29427 & ' interactions in proj./ target (mean per evt1)',
29428 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29429 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29430 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29431 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29432 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29433 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29434 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29435 & 'evaporation',/,22X,'-----------------------------',
29436 & '------------',/,/,1X,'no. of events for normal.: ',
29437 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29438 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29439 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29442 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29443 ICEV = MAX(NRESEV(2),1)
29445 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29446 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29447 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29448 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29449 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29450 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29451 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29452 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29453 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29454 & 'proj. / target',/,/,8X,'total number of particles',15X,
29455 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29456 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29457 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29458 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29459 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29461 * evaporation / fission / fragmentation statistics: output
29462 ICEV = MAX(NRESEV(2),1)
29463 ICEV1 = MAX(NRESEV(4),1)
29465 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29467 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29469 IF (IFISS.EQ.1) CMSG(1) = 'requested '
29470 IF (LFRMBK) CMSG(2) = 'requested '
29471 IF (LDEEXG) CMSG(3) = 'requested '
29474 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29475 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29476 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29477 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29478 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29479 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29480 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29481 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29482 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29483 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29484 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29485 & 'deexcitation:',2X,A13,/,/,
29486 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29487 & 'proj. / target',/,/,8X,'total number of evap. particles',
29488 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29489 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29490 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29491 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29492 & 'heavy fragments',25X,2F9.3,/)
29493 IF (IFISS.EQ.1) THEN
29494 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29495 & NEVAFI(2,1),NEVAFI(2,2),
29496 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29497 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29498 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29499 & 12X,'out of which fission occured',8X,2I9,/,
29500 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29502 C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29504 C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29505 C & ' proj. / target',/)
29507 C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29508 C WRITE(LOUT,3009) I,
29509 C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29510 C3009 FORMAT(38X,I3,3X,2E12.3)
29514 C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29515 C & ' proj. / target',/)
29517 C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29518 C WRITE(LOUT,3011) I,
29519 C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29520 C3011 FORMAT(38X,I3,3X,2E12.3)
29527 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29528 & 'Evaporation: not requested',/)
29532 *------------------------------------------------------------------
29533 * filling of histogram with event-record
29535 * emulsion treatment
29536 IF (NCOMPO.GT.0) THEN
29538 IF (IT.EQ.IEMUMA(I)) THEN
29539 EMUSAM(I) = EMUSAM(I)+ONE
29543 NINCGE = NINCGE+MAXGEN
29545 **dble Po statistics.
29546 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29549 *------------------------------------------------------------------
29550 * filling of histogram with event-record
29552 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29553 IB = IIBAR(IDBAM(IDX))
29554 IC = IICH(IDBAM(IDX))
29556 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29557 NINCST(J,1) = NINCST(J,1)+1
29558 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29559 NINCST(J,2) = NINCST(J,2)+1
29560 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29561 NINCST(J,3) = NINCST(J,3)+1
29562 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29563 NINCST(J,4) = NINCST(J,4)+1
29565 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29566 NINCWO(1) = NINCWO(1)+1
29567 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29568 NINCWO(2) = NINCWO(2)+1
29569 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29573 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29574 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29576 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29582 *$ CREATE DT_NEWHGR.FOR
29585 *===newhgr=============================================================*
29587 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29589 ************************************************************************
29591 * Histogram initialization. *
29593 * input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29595 * IBIN > 0 number of bins in equidistant lin. binning *
29596 * = -1 reset histograms *
29597 * < -1 |IBIN| number of bins in equidistant log. *
29598 * binning or log. binning in user def. struc. *
29599 * XLIMB(*) user defined bin structure *
29601 * The bin structure is sensitive to *
29602 * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29603 * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29604 * XLIMB, IBIN if XLIM3 < 0 *
29607 * output: IREFN histogram index *
29608 * (= -1 for inconsistent histogr. request) *
29610 * This subroutine is based on a original version by R. Engel. *
29611 * This version dated 22.4.95 is written by S. Roesler. *
29612 ************************************************************************
29614 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29616 PARAMETER ( LINP = 10 ,
29622 PARAMETER (ZERO = 0.0D0,
29628 PARAMETER (NHIS=150, NDIM=250)
29629 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29630 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29631 * auxiliary common for histograms
29632 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29634 DATA LSTART /.TRUE./
29636 * reset histogram counter
29637 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29639 IF (IBIN.EQ.-1) RETURN
29644 * check for maximum number of allowed histograms
29645 IF (IHIS.GT.NHIS) THEN
29646 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29647 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29648 & I4,') exceeds array size (',I4,')',/,21X,
29649 & 'histogram',I3,' skipped!')
29654 IBINS(IHIS) = ABS(IBIN)
29655 * check requested number of bins
29656 IF (IBINS(IHIS).GE.NDIM) THEN
29657 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29658 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29659 & I3,') exceeds array size (',I3,')',/,21X,
29660 & 'and will be reset to ',I3)
29663 IF (IBINS(IHIS).EQ.0) THEN
29664 WRITE(LOUT,1001) IBIN,IHIS
29665 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29666 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29670 * initialize arrays
29673 HIST(K,IHIS,I) = ZERO
29674 HIST(K+3,IHIS,I) = ZERO
29675 TMPHIS(K,IHIS,I) = ZERO
29677 HIST(7,IHIS,I) = ZERO
29679 DENTRY(1,IHIS)= ZERO
29680 DENTRY(2,IHIS)= ZERO
29682 UNDERF(IHIS) = ZERO
29683 TMPUFL(IHIS) = ZERO
29684 TMPOFL(IHIS) = ZERO
29686 * bin str. sensitive to lower edge, bin size, and numb. of bins
29687 IF (XLIM3.GT.ZERO) THEN
29688 DO 3 K=1,IBINS(IHIS)+1
29689 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29692 * bin str. sensitive to lower/upper edge and numb. of bins
29693 ELSEIF (XLIM3.EQ.ZERO) THEN
29695 IF (IBIN.GT.0) THEN
29698 IF (XLIM2.LE.XLIM1) THEN
29699 WRITE(LOUT,1002) XLIM1,XLIM2
29700 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29701 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29705 ELSEIF (IBIN.LT.-1) THEN
29706 * logarithmic binning
29707 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29708 WRITE(LOUT,1004) XLIM1,XLIM2
29709 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29710 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29713 IF (XLIM2.LE.XLIM1) THEN
29714 WRITE(LOUT,1005) XLIM1,XLIM2
29715 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29716 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29719 XLOW = LOG10(XLIM1)
29723 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29724 DO 4 K=1,IBINS(IHIS)+1
29725 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29728 * user defined bin structure
29729 DO 5 K=1,IBINS(IHIS)+1
29730 IF (IBIN.GT.0) THEN
29731 HIST(1,IHIS,K) = XLIMB(K)
29733 ELSEIF (IBIN.LT.-1) THEN
29734 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29740 * histogram accepted
29750 *$ CREATE DT_FILHGR.FOR
29753 *===filhgr=============================================================*
29755 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29757 ************************************************************************
29759 * Scoring for histogram IHIS. *
29761 * This subroutine is based on a original version by R. Engel. *
29762 * This version dated 23.4.95 is written by S. Roesler. *
29763 ************************************************************************
29765 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29767 PARAMETER ( LINP = 10 ,
29771 PARAMETER (ZERO = 0.0D0,
29776 PARAMETER (NHIS=150, NDIM=250)
29777 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29778 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29779 * auxiliary common for histograms
29780 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29787 * dump content of temorary arrays into histograms
29788 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29789 CALL DT_EVTHIS(IDUM)
29793 * check histogram index
29794 IF (IHIS.EQ.-1) RETURN
29795 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29796 C WRITE(LOUT,1000) IHIS,IHISL
29797 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29798 & ' out of range (1..',I3,')')
29802 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29803 * bin structure not explicitly given
29804 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29805 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29806 IF (X.LT.HIST(1,IHIS,1)) THEN
29809 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29812 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29813 * user defined bin structure
29814 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29815 IF (X.LT.HIST(1,IHIS,1)) THEN
29817 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29820 * binary sort algorithm
29822 KMAX = IBINS(IHIS)+1
29824 IF ((KMAX-KMIN).EQ.1) GOTO 2
29826 IF (X.LE.HIST(1,IHIS,KK)) THEN
29838 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29844 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29845 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29846 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29847 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29848 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29850 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29852 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29854 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29860 *$ CREATE DT_EVTHIS.FOR
29863 *===evthis=============================================================*
29865 SUBROUTINE DT_EVTHIS(NEVT)
29867 ************************************************************************
29868 * Dump content of temorary histograms into /DTHIS1/. This subroutine *
29869 * is called after each event and for the last event before any call *
29871 * NEVT number of events dumped, this is only needed to *
29872 * get the normalization after the last event *
29873 * This version dated 23.4.95 is written by S. Roesler. *
29874 ************************************************************************
29876 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29878 PARAMETER ( LINP = 10 ,
29884 PARAMETER (ZERO = 0.0D0,
29889 PARAMETER (NHIS=150, NDIM=250)
29890 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29891 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29892 * auxiliary common for histograms
29893 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29903 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29905 HIST(2,I,J) = HIST(2,I,J)+ONE
29906 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29907 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29908 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29909 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29910 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29911 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29912 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29913 TMPHIS(1,I,J) = ZERO
29914 TMPHIS(2,I,J) = ZERO
29915 TMPHIS(3,I,J) = ZERO
29919 IF (TMPUFL(I).GT.ZERO) THEN
29920 UNDERF(I) = UNDERF(I)+ONE
29922 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29923 OVERF(I) = OVERF(I)+ONE
29927 DENTRY(1,I) = DENTRY(1,I)+ONE
29934 *$ CREATE DT_OUTHGR.FOR
29937 *===outhgr=============================================================*
29939 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29940 & ILOGY,INORM,NMODE)
29942 ************************************************************************
29944 * Plot histogram(s) to standard output unit *
29946 * I1..6 indices of histograms to be plotted *
29947 * CHEAD,IHEAD header string,integer *
29948 * NEVTS number of events *
29949 * FAC scaling factor *
29950 * ILOGY = 1 logarithmic y-axis *
29951 * INORM normalization *
29952 * = 0 no further normalization (FAC is obsolete) *
29953 * = 1 per event and bin width *
29954 * = 2 per entry and bin width *
29955 * = 3 per bin entry *
29956 * = 4 per event and "bin width" x1^2...x2^2 *
29957 * = 5 per event and "log. bin width" ln x1..ln x2 *
29959 * MODE = 0 no output but normalization applied *
29960 * = 1 all valid histograms separately (small frame) *
29961 * all valid histograms separately (small frame) *
29962 * = -1 and tables as histograms *
29963 * = 2 all valid histograms (one plot, wide frame) *
29964 * all valid histograms (one plot, wide frame) *
29965 * = -2 and tables as histograms *
29968 * Note: All histograms to be plotted with one call to this *
29969 * subroutine and |MODE|=2 must have the same bin structure! *
29970 * There is no test included ensuring this fact. *
29972 * This version dated 23.4.95 is written by S. Roesler. *
29973 ************************************************************************
29975 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29977 PARAMETER ( LINP = 10 ,
29983 PARAMETER (ZERO = 0.0D0,
29994 PARAMETER (NHIS=150, NDIM=250)
29995 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29996 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29998 PARAMETER (NDIM2 = 2*NDIM)
29999 DIMENSION XX(NDIM2),YY(NDIM2)
30001 PARAMETER (NHISTO = 6)
30002 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30005 CHARACTER*43 CNORM(0:8)
30006 DATA CNORM /'no further normalization ',
30007 & 'per event and bin width ',
30008 & 'per entry1 and bin width ',
30009 & 'per bin entry ',
30010 & 'per event and "bin width" x1^2...x2^2 ',
30011 & 'per event and "log. bin width" ln x1..ln x2',
30013 & 'per bin entry1 ',
30014 & 'per entry2 and bin width '/
30025 * initialization if "wide frame" is requested
30026 IF (ABS(MODE).EQ.2) THEN
30036 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30038 * check histogram indices
30041 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30042 IF (ISWI(IDX1(I)).NE.0) THEN
30043 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30045 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30046 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
30047 & ' histogram ',I3,/,21X,'underflows:',F10.0,
30048 & ' overflows: ',F10.0)
30058 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30062 * check normalization request
30063 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30064 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30065 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30066 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30067 WRITE(LOUT,1002) NEVTS,INORM,FAC
30068 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30069 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30074 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30076 * apply normalization
30081 IF (ISWI(I).EQ.1) THEN
30082 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30083 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30084 & ' to',2X,E10.4,',',2X,I3,' bins')
30085 ELSEIF (ISWI(I).EQ.2) THEN
30086 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30088 1007 FORMAT(1X,'user defined bin structure')
30089 ELSEIF (ISWI(I).EQ.3) THEN
30091 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30092 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30093 & ' to',2X,E10.4,',',2X,I3,' bins')
30094 ELSEIF (ISWI(I).EQ.4) THEN
30096 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30099 WRITE(LOUT,1008) ISWI(I)
30100 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30102 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30103 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30104 & ' overfl.:',F8.0)
30105 WRITE(LOUT,1009) CNORM(INORM)
30106 1009 FORMAT(1X,'normalization: ',A,/)
30109 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30112 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30113 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30114 1006 FORMAT(1X,5E11.3)
30117 XX(II-1) = HIST(1,I,K)
30118 XX(II) = HIST(1,I,K+1)
30123 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30124 & XX1(K,N) = LOG10(XMEAN)
30129 IF (ABS(MODE).EQ.1) THEN
30131 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30132 IF(ILOGY.EQ.1) THEN
30133 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30135 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30142 IF (ABS(MODE).EQ.2) THEN
30143 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30144 NSIZE = NDIM*NHISTO
30145 DXLOW = HIST(1,IDX(1),1)
30146 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30151 IF (YY1(J,I).LT.YLOW) THEN
30152 IF (ILOGY.EQ.1) THEN
30153 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30158 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30161 DY = (YHI-YLOW)/DBLE(NDIM)
30162 IF (DY.LE.ZERO) THEN
30163 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30164 & 'OUTHGR: warning! zero bin width for histograms ',
30165 & IDX,': ',YLOW,YHI
30168 IF (ILOGY.EQ.1) THEN
30170 DY = (LOG10(YHI)-YLOW)/100.0D0
30173 IF (YY1(J,I).LE.ZERO) THEN
30176 YY1(J,I) = LOG10(YY1(J,I))
30181 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30187 *$ CREATE DT_GETBIN.FOR
30190 *===getbin=============================================================*
30192 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30193 & XMEAN,YMEAN,YERR)
30195 ************************************************************************
30196 * This version dated 23.4.95 is written by S. Roesler. *
30197 ************************************************************************
30199 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30201 PARAMETER ( LINP = 10 ,
30205 PARAMETER (ZERO = 0.0D0,
30207 & TINY35 = 1.0D-35)
30210 PARAMETER (NHIS=150, NDIM=250)
30211 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30212 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30214 XLOW = HIST(1,IHIS,IBIN)
30215 XHI = HIST(1,IHIS,IBIN+1)
30216 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30220 IF (NORM.EQ.2) THEN
30222 NEVT = INT(DENTRY(1,IHIS))
30223 ELSEIF (NORM.EQ.3) THEN
30225 NEVT = INT(HIST(2,IHIS,IBIN))
30226 ELSEIF (NORM.EQ.4) THEN
30227 DX = XHI**2-XLOW**2
30229 ELSEIF (NORM.EQ.5) THEN
30230 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30232 ELSEIF (NORM.EQ.6) THEN
30235 ELSEIF (NORM.EQ.7) THEN
30237 NEVT = INT(HIST(7,IHIS,IBIN))
30238 ELSEIF (NORM.EQ.8) THEN
30240 NEVT = INT(DENTRY(2,IHIS))
30245 IF (ABS(DX).LT.TINY35) DX = ONE
30247 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30248 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30249 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30250 YSUM = HIST(5,IHIS,IBIN)
30251 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30252 C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30253 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30254 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30259 *$ CREATE DT_JOIHIS.FOR
30262 *===joihis=============================================================*
30264 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30266 ************************************************************************
30268 * Operation on histograms. *
30270 * input: IH1,IH2 histogram indices to be joined *
30271 * COPER character defining the requested operation, *
30272 * i.e. '+', '-', '*', '/' *
30273 * FAC1,FAC2 factors for joining, i.e. *
30274 * FAC1*histo1 COPER FAC2*histo2 *
30276 * This version dated 23.4.95 is written by S. Roesler. *
30277 ************************************************************************
30279 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30281 PARAMETER ( LINP = 10 ,
30287 PARAMETER (ZERO = 0.0D0,
30295 PARAMETER (NHIS=150, NDIM=250)
30296 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30297 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30299 PARAMETER (NDIM2 = 2*NDIM)
30300 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30302 CHARACTER*43 CNORM(0:6)
30303 DATA CNORM /'no further normalization ',
30304 & 'per event and bin width ',
30305 & 'per entry and bin width ',
30306 & 'per bin entry ',
30307 & 'per event and "bin width" x1^2...x2^2 ',
30308 & 'per event and "log. bin width" ln x1..ln x2',
30311 * check histogram indices
30312 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30313 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30314 WRITE(LOUT,1000) IH1,IH2,IHISL
30315 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30316 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30320 * check bin structure of histograms to be joined
30321 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30322 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30323 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30324 & ' and ',I3,' failed',/,21X,
30325 & 'due to different numbers of bins (',I3,',',I3,')')
30328 DO 1 K=1,IBINS(IH1)+1
30329 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30330 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30331 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30332 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30333 & 'X1,X2 = ',2E11.4)
30338 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30339 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30340 & 'operation ',A,/,11X,'and factors ',2E11.4)
30341 WRITE(LOUT,1004) CNORM(NORM)
30342 1004 FORMAT(1X,'normalization: ',A,/)
30344 DO 2 K=1,IBINS(IH1)
30345 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30346 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30349 XMEAN = OHALF*(XMEAN1+XMEAN2)
30350 IF (COPER.EQ.'+') THEN
30351 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30352 ELSEIF (COPER.EQ.'*') THEN
30353 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30354 ELSEIF (COPER.EQ.'/') THEN
30355 IF (YMEAN2.EQ.ZERO) THEN
30358 IF (FAC2.EQ.ZERO) FAC2 = ONE
30359 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30364 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30365 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30366 1006 FORMAT(1X,5E11.3)
30369 XX(II-1) = HIST(1,IH1,K)
30370 XX(II) = HIST(1,IH1,K+1)
30375 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30380 IF (ABS(MODE).EQ.1) THEN
30381 IBIN2 = 2*IBINS(IH1)
30382 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30383 IF(ILOGY.EQ.1) THEN
30384 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30386 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30391 IF (ABS(MODE).EQ.2) THEN
30392 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30394 DXLOW = HIST(1,IH1,1)
30395 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30399 IF (YY1(I).LT.YLOW) THEN
30400 IF (ILOGY.EQ.1) THEN
30401 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30406 IF (YY1(I).GT.YHI) YHI = YY1(I)
30408 DY = (YHI-YLOW)/DBLE(NDIM)
30409 IF (DY.LE.ZERO) THEN
30410 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30411 & 'JOIHIS: warning! zero bin width for histograms ',
30412 & IH1,IH2,': ',YLOW,YHI
30415 IF (ILOGY.EQ.1) THEN
30417 DY = (LOG10(YHI)-YLOW)/100.0D0
30419 IF (YY1(I).LE.ZERO) THEN
30422 YY1(I) = LOG10(YY1(I))
30426 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30432 WRITE(LOUT,1005) COPER
30433 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30439 *$ CREATE DT_XGRAPH.FOR
30442 *===qgraph=============================================================*
30444 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30445 C***********************************************************************
30447 C calculate quasi graphic picture with 25 lines and 79 columns
30448 C ranges will be chosen automatically
30450 C input N dimension of input fields
30451 C IARG number of curves (fields) to plot
30456 C This subroutine is written by R. Engel.
30457 C***********************************************************************
30458 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30461 PARAMETER ( LINP = 10 ,
30465 DIMENSION X(N),Y1(N),Y2(N)
30466 PARAMETER (EPS=1.D-30)
30467 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30469 CHARACTER COL(0:149,0:49)
30471 DATA SYMB /'0','e','z','#','x'/
30475 C*** automatic range fitting
30480 XMAX=MAX(X(I),XMAX)
30481 XMIN=MIN(X(I),XMIN)
30483 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30486 DO 1100 K=0,IZEIL-1
30488 IF (ITEST.EQ.IYRAST) THEN
30489 DO 1010 L=1,ISPALT-1
30494 DO 1020 L=0,ISPALT-1,IXRAST
30498 DO 1030 L=1,ISPALT-1
30501 DO 1040 L=0,ISPALT-1,IXRAST
30513 YMAX=MAX(Y1(I),YMAX)
30514 YMIN=MIN(Y1(I),YMIN)
30518 YMAX=MAX(Y2(I),YMAX)
30519 YMIN=MIN(Y2(I),YMIN)
30522 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30523 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30524 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30525 IF(YZOOM.LT.EPS) THEN
30526 WRITE(LOUT,'(1X,A)')
30527 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30536 L=NINT((X(K)-XMIN)/XZOOM)
30537 I=NINT((YMAX-Y1(K))/YZOOM)
30538 IF(ILAST.GE.0) THEN
30541 DO 55 II=0,LD,SIGN(1,LD)
30542 DO 66 KK=0,ID,SIGN(1,ID)
30543 COL(II+LLAST,KK+ILAST)=SYMB(1)
30558 L=NINT((X(K)-XMIN)/XZOOM)
30559 I=NINT((YMAX-Y2(K))/YZOOM)
30566 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30568 C*** write range of X
30570 XZOOM = (XMAX-XMIN)/DBLE(7)
30571 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30573 DO 1300 K=0,IZEIL-1
30574 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30575 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30576 110 FORMAT(1X,1PE9.2,70A1)
30579 C*** write range of X
30581 XZOOM = (XMAX-XMIN)/DBLE(7)
30582 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30583 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30584 120 FORMAT(6X,7(1PE10.3))
30587 *$ CREATE DT_XGLOGY.FOR
30590 *===qglogy=============================================================*
30592 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30593 C***********************************************************************
30595 C calculate quasi graphic picture with 25 lines and 79 columns
30596 C logarithmic y axis
30597 C ranges will be chosen automatically
30599 C input N dimension of input fields
30600 C IARG number of curves (fields) to plot
30605 C This subroutine is written by R. Engel.
30606 C***********************************************************************
30608 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30611 PARAMETER ( LINP = 10 ,
30614 DIMENSION X(N),Y1(N),Y2(N)
30615 PARAMETER (EPS=1.D-30)
30616 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30618 CHARACTER COL(0:149,0:49)
30619 PARAMETER (DEPS = 1.D-10)
30621 DATA SYMB /'0','e','z','#','x'/
30625 C*** automatic range fitting
30630 XMAX=MAX(X(I),XMAX)
30631 XMIN=MIN(X(I),XMIN)
30633 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30636 DO 1100 K=0,IZEIL-1
30638 IF (ITEST.EQ.IYRAST) THEN
30639 DO 1010 L=1,ISPALT-1
30644 DO 1020 L=0,ISPALT-1,IXRAST
30648 DO 1030 L=1,ISPALT-1
30651 DO 1040 L=0,ISPALT-1,IXRAST
30661 YMIN=MAX(Y1(1),EPS)
30663 YMAX =MAX(Y1(I),YMAX)
30664 IF(Y1(I).GT.EPS) THEN
30665 IF(YMIN.EQ.EPS) THEN
30668 YMIN = MIN(Y1(I),YMIN)
30674 YMAX=MAX(Y2(I),YMAX)
30675 IF(Y2(I).GT.EPS) THEN
30676 IF(YMIN.EQ.EPS) THEN
30679 YMIN = MIN(Y2(I),YMIN)
30686 Y1(I) = MAX(Y1(I),YMIN)
30690 Y2(I) = MAX(Y2(I),YMIN)
30694 IF(YMAX.LE.YMIN) THEN
30695 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30696 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30697 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30701 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30702 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30703 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30704 IF(YZOOM.LT.EPS) THEN
30705 WRITE(LOUT,'(1X,A)')
30706 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30715 L=NINT((X(K)-XMIN)/XZOOM)
30716 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30717 IF(ILAST.GE.0) THEN
30720 DO 55 II=0,LD,SIGN(1,LD)
30721 DO 66 KK=0,ID,SIGN(1,ID)
30722 COL(II+LLAST,KK+ILAST)=SYMB(1)
30737 L=NINT((X(K)-XMIN)/XZOOM)
30738 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30745 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30746 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30748 C*** write range of X
30750 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30751 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30753 DO 1300 K=0,IZEIL-1
30754 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30755 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30756 110 FORMAT(1X,1PE9.2,70A1)
30759 C*** write range of X
30761 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30762 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30763 120 FORMAT(6X,7(1PE10.3))
30767 *$ CREATE DT_SRPLOT.FOR
30770 *===plot===============================================================*
30772 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30774 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30777 PARAMETER ( LINP = 10 ,
30782 * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30783 * This is a subroutine of fluka to plot Y across the page
30784 * as a function of X down the page. Up to 37 curves can be
30785 * plotted in the same picture with different plotting characters.
30786 * Output of first 10 overprinted characters addad by FB 88
30787 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30790 * X = array containing the values of X
30791 * Y = array containing the values of Y
30792 * N = number of values in X and in Y
30793 * can exceed the fixed number of lines
30794 * M = number of different curves X,Y are containing
30795 * MM = number of points in each curve i.e. N=M*MM
30796 * XO = smallest value of X to be plotted
30797 * DX = increment of X between subsequent lines
30798 * YO = smallest value of Y to be plotted
30799 * DY = increment of Y between subsequent character spaces
30801 * other variables used inside:
30802 * XX = numbers along the X-coordinate axis
30803 * YY = numbers along the Y-coordinate axis
30804 * LL = ten lines temporary storage for the plot
30805 * L = character set used to plot different curves
30806 * LOV = memorizes overprinted symbols
30807 * the first 10 overprinted symbols are printed on
30808 * the end of the line to avoid ambiguities
30809 * (added by FB as considered quite helpful)
30811 *********************************************************************
30813 DIMENSION XX(61),YY(61),LL(101,10)
30814 DIMENSION X(N),Y(N),L(40),LOV(40,10)
30815 INTEGER*4 LL, L, LOV
30817 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30818 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30819 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30820 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30829 20 YY(I)=YO+10.0D0*AI*DY
30830 WRITE(LOUT, 500) (YY(I),I=1,11)
30852 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30853 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30855 * changed Sept.88 by FB to avoid INTEGER OVERFLOW
30856 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30857 + . AIY .LT. 102.D0) THEN
30860 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30862 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30873 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30874 & (LOV(J,I),J=1,10)
30880 WRITE(LOUT, 500) (YY(I),I=1,11)
30883 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30884 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30885 520 FORMAT(20X,10('1---------'),'1')
30888 *$ CREATE DT_DEFSET.FOR
30891 *===defset=============================================================*
30893 BLOCK DATA DT_DEFSET
30895 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30898 * flags for input different options
30899 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30900 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30901 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30902 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30903 * emulsion treatment
30904 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30908 DATA IFRAG / 2, 1 /
30912 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30913 DATA LEMCCK / .FALSE. /
30914 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30915 & .TRUE.,.TRUE.,.TRUE./
30916 DATA LSEADI / .TRUE. /
30917 DATA LEVAPO / .TRUE. /
30922 DATA EMUFRA / NCOMPX*0.0D0 /
30923 DATA IEMUMA / NCOMPX*1 /
30924 DATA IEMUCH / NCOMPX*1 /
30930 *$ CREATE DT_HADPRP.FOR
30933 *===hadprp=============================================================*
30935 BLOCK DATA DT_HADPRP
30937 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30940 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30941 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30942 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30943 & IQTCHR(-6:6),MQUARK(3,39)
30944 * hadron index conversion (BAMJET <--> PDG)
30945 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30946 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30948 * names of hadrons used in input-cards
30950 COMMON /DTPAIN/ BTYPE(30)
30953 *----------------------------------------------------------------------*
30955 * Quark content of particles: *
30956 * index quark el. charge bar. charge isospin isospin3 *
30957 * 1 = u 2/3 1/3 1/2 1/2 *
30958 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
30959 * 2 = d -1/3 1/3 1/2 -1/2 *
30960 * -2 = dbar 1/3 -1/3 1/2 1/2 *
30961 * 3 = s -1/3 1/3 0 0 *
30962 * -3 = sbar 1/3 -1/3 0 0 *
30963 * 4 = c 2/3 1/3 0 0 *
30964 * -4 = cbar -2/3 -1/3 0 0 *
30965 * 5 = b -1/3 1/3 0 0 *
30966 * -5 = bbar 1/3 -1/3 0 0 *
30967 * 6 = t 2/3 1/3 0 0 *
30968 * -6 = tbar -2/3 -1/3 0 0 *
30970 * Mquark = particle quark composition (Paprop numbering) *
30971 * Iqechr = electric charge ( in 1/3 unit ) *
30972 * Iqbchr = baryonic charge ( in 1/3 unit ) *
30973 * Iqichr = isospin ( in 1/2 unit ), z component *
30974 * Iqschr = strangeness *
30976 * Iquchr = beauty *
30977 * Iqtchr = ...... *
30979 *----------------------------------------------------------------------*
30980 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30981 DATA IQBCHR / 6*-1, 0, 6*1 /
30982 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30983 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30984 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30985 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30986 DATA IQTCHR / -1, 11*0, 1 /
30988 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30989 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
30990 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
30991 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
30992 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
30993 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30994 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
30995 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
30998 * (renamed) (HAdron InDex COnversion)
30999 * translation table version filled up by r.e. 25.01.94 *
31001 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
31002 &13,130,211,-211,321, -321,3122,-3122,310,3112,
31003 &3222,3212,111,311,-311, 0,0,0,0,0,
31004 &221,213,113,-213,223, 323,313,-323,-313,10323,
31005 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
31006 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
31007 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
31008 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31010 &4*99999,331, 333,3322,3312,-3222,-3212,
31011 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
31012 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
31013 &-431,441,423,413,-413, -423,433,-433,20443,443,
31014 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
31015 &4212,4112,3*99999, 3*99999,-4122,-4232,
31016 &-4132,-4222,-4212,-4112,99999, 5*99999,
31019 &5*99999 , 20211,20111,-20211,99999,20321,
31020 &-20321,20311,-20311,7*99999 ,
31021 &7*99999,12212,12112,99999/
31024 * (HAdron InDex COnversion)
31025 DATA (IPDG2(1,K),K=1,7)
31026 & / -11, -12, -13, -15, -16, -14, 0/
31027 DATA (IBAM2(1,K),K=1,7)
31028 & / 4, 6, 10, 131, 134, 136, 0/
31029 DATA (IPDG2(2,K),K=1,7)
31030 & / 11, 12, 22, 13, 15, 16, 14/
31031 DATA (IBAM2(2,K),K=1,7)
31032 & / 3, 5, 7, 11, 132, 133, 135/
31033 DATA (IPDG3(1,K),K=1,22)
31034 & / -211, -321, -311, -213, -323, -313, -411, -421,
31035 & -431, -413, -423, -433, 0, 0, 0, 0,
31036 & 0, 0, 0, 0, 0, 0/
31037 DATA (IBAM3(1,K),K=1,22)
31038 & / 14, 16, 25, 34, 38, 39, 118, 119,
31039 & 121, 125, 126, 128, 0, 0, 0, 0,
31040 & 0, 0, 0, 0, 0, 0/
31041 DATA (IPDG3(2,K),K=1,22)
31042 & / 130, 211, 321, 310, 111, 311, 221, 213,
31043 & 113, 223, 323, 313, 331, 333, 421, 411,
31044 & 431, 441, 423, 413, 433, 443/
31045 DATA (IBAM3(2,K),K=1,22)
31046 & / 12, 13, 15, 19, 23, 24, 31, 32,
31047 & 33, 35, 36, 37, 95, 96, 116, 117,
31048 & 120, 122, 123, 124, 127, 130/
31049 DATA (IPDG4(1,K),K=1,29)
31050 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31051 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31052 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31053 & -4212, -4112, 0, 0, 0/
31054 DATA (IBAM4(1,K),K=1,29)
31055 & / 2, 9, 18, 67, 68, 69, 70, 75,
31056 & 76, 99, 100, 101, 102, 103, 110, 111,
31057 & 112, 113, 114, 115, 149, 150, 151, 152,
31058 & 153, 154, 0, 0, 0/
31059 DATA (IPDG4(2,K),K=1,29)
31060 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31061 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31062 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31063 & 4232, 4132, 4222, 4212, 4112/
31064 DATA (IBAM4(2,K),K=1,29)
31065 & / 1, 8, 17, 20, 21, 22, 48, 49,
31066 & 50, 51, 52, 53, 54, 55, 56, 97,
31067 & 98, 104, 105, 106, 107, 108, 109, 137,
31068 & 138, 139, 140, 141, 142/
31069 DATA (IPDG5(1,K),K=1,19)
31070 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31071 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31073 DATA (IBAM5(1,K),K=1,19)
31074 & / 42, 43, 46, 47, 71, 72, 73, 74,
31075 & 188, 191, 193, 0, 0, 0, 0, 0,
31077 DATA (IPDG5(2,K),K=1,19)
31078 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31079 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31080 & 20311, 12212, 12112/
31081 DATA (IBAM5(2,K),K=1,19)
31082 & / 40, 41, 44, 45, 57, 58, 59, 60,
31083 & 63, 64, 65, 66, 129, 186, 187, 190,
31087 * internal particle names
31088 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31089 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31090 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31091 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31092 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31093 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31098 *$ CREATE DT_BLKD46.FOR
31101 *===blkd46=============================================================*
31103 BLOCK DATA DT_BLKD46
31105 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31108 PARAMETER ( AMELCT = 0.51099906 D-03 )
31109 PARAMETER ( AMMUON = 0.105658389 D+00 )
31111 * particle properties (BAMJET index convention)
31113 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31114 & IICH(210),IIBAR(210),K1(210),K2(210)
31117 * Particle masses Engel version JETSET compatible
31118 C DATA (AAM(K),K=1,85) /
31119 C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31120 C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31121 C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31122 C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31123 C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31124 C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31125 C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31126 C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31127 C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31128 C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31129 C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31130 C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31131 C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31132 C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31133 C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31134 C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31135 C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31136 C DATA (AAM(K),K=86,183) /
31137 C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31138 C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31139 C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31140 C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31141 C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31142 C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31143 C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31144 C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31145 C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31146 C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31147 C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31148 C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31149 C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31150 C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31151 C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31152 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31153 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31154 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31155 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31156 C & .1250D+01, .1250D+01, .1250D+01 /
31157 C DATA (AAM ( I ), I = 184,210 ) /
31158 C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31159 C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31160 C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31161 C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31162 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31163 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31164 C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31165 C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31166 C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31167 * sr 25.1.06: particle masses adjusted to Pythia
31168 DATA (AAM(K),K=1,85) /
31169 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31170 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31171 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31172 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31173 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31174 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31175 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31176 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31177 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31178 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31179 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31180 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31181 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31182 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31183 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31184 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31185 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31186 DATA (AAM(K),K=86,183) /
31187 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31188 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31189 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31190 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31191 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31192 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31193 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31194 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31195 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31196 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31197 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31198 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31199 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31200 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31201 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31202 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31203 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31204 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31205 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31206 & .1250D+01, .1250D+01, .1250D+01 /
31207 DATA (AAM ( I ), I = 184,210 ) /
31208 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31209 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31210 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31211 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31212 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31213 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31214 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31215 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31216 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31217 * Particle mean lives
31218 DATA (TAU(K),K=1,183) /
31219 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31220 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31221 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31222 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31223 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31225 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31226 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31227 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31228 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31229 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31230 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31231 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31232 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31233 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31235 & .0000D+00, .0000D+00, .0000D+00 /
31236 DATA ( TAU ( I ), I = 184,210 ) /
31237 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31238 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31239 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31240 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31241 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31242 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31243 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31244 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31245 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31246 * Resonance width Gamma in GeV
31247 DATA (GA(K),K= 1,85) /
31249 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31250 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31251 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31252 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31253 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31254 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31255 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31256 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31257 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31258 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31259 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31260 DATA (GA(K),K= 86,183) /
31261 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31262 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31263 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31264 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31265 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31266 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31267 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31268 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31269 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31271 & .3000D+00, .3000D+00, .3000D+00 /
31272 DATA ( GA ( I ), I = 184,210 ) /
31273 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31274 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31275 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31276 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31277 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31278 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31279 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31280 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31281 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31283 * S+1385+Sigma+(1385) L02030+Lambda0(2030)
31284 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31285 * designation N*@@ means N*@1(@2)
31286 DATA (ANAME(K),K=1,85) /
31287 & 'P ','AP ','E- ','E+ ','NUE ',
31288 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31289 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31290 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31291 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31292 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31293 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31294 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31295 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31296 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31297 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31298 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31299 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31300 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31301 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31302 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31303 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31304 DATA (ANAME(K),K=86,183) /
31305 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31306 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31307 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31308 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31309 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31310 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31311 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31312 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31313 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31314 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31315 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31316 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31317 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31318 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31319 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31320 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31321 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31322 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31323 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31324 & 'RO ','R+ ','R- ' /
31325 DATA ( ANAME ( I ), I = 184,210 ) /
31326 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31327 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31328 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31329 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31330 &'N*+14 ','N*014 ','BLANK '/
31331 * Charge of particles and resonances
31332 DATA (IICH ( I ), I = 1,210 ) /
31333 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31334 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31335 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31336 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31337 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31338 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31339 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31340 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31341 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31342 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31343 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31344 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31345 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31346 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31347 * Particle baryonic charges
31348 DATA (IIBAR ( I ), I = 1,210 ) /
31349 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31350 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31351 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31352 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31353 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31354 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31355 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31356 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31357 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31358 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31359 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31360 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31361 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31362 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31363 * First number of decay channels used for resonances
31364 * and decaying particles
31365 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31366 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31367 & 2*330, 46, 51, 52, 54, 55, 58,
31369 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31370 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31371 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31373 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31374 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31375 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31376 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31377 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31378 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31379 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31380 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31381 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31382 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31384 * Last number of decay channels used for resonances
31385 * and decaying particles
31386 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31387 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31388 & 2* 330, 50, 51, 53, 54, 57,
31390 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31391 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31392 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31394 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31395 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31396 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31397 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31398 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31399 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31400 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31401 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31402 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31403 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31404 & 589, 595, 601, 602 /
31408 *$ CREATE DT_BLKD47.FOR
31411 *===blkd47=============================================================*
31413 BLOCK DATA DT_BLKD47
31415 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31418 * HADRIN: decay channel information
31419 PARAMETER (IDMAX9=602)
31421 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31423 * Name of decay channel
31424 * Designation N*@ means N*@1(1236)
31425 * @1=# means ++, @1 = = means --
31426 * Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31427 DATA (ZKNAME(K),K= 1, 85) /
31428 & 'P ','AP ','E- ','E+ ','NUE ',
31429 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31430 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31431 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31432 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31433 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31434 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31435 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31436 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31437 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31438 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31439 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31440 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31441 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31442 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31443 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31444 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31445 DATA (ZKNAME(K),K= 86,170) /
31446 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31447 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31448 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31449 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31450 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31451 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31452 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31453 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31454 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31455 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31456 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31457 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31458 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31459 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31460 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31461 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31462 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31463 DATA (ZKNAME(K),K=171,255) /
31464 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31465 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31466 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31467 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31468 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31469 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31470 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31471 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31472 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31473 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31474 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31475 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31476 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31477 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31478 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31479 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31480 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31481 DATA (ZKNAME(K),K=256,340) /
31482 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31483 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31484 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31485 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31486 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31487 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31488 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31489 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31490 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31491 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31492 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31493 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31494 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31495 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31496 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31497 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31498 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31499 DATA (ZKNAME(K),K=341,425) /
31500 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31501 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31502 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31503 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31504 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31505 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31506 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31507 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31508 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31509 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31510 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31511 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31512 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31513 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31514 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31515 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31516 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31517 DATA (ZKNAME(K),K=426,510) /
31518 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31519 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31520 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31521 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31522 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31523 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31524 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31525 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31526 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31527 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31528 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31529 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31530 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31531 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31532 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31533 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31534 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31535 DATA (ZKNAME(K),K=511,540) /
31536 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31537 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31538 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31539 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31540 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31541 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31542 DATA (ZKNAME(I),I=541,602)/
31543 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31544 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31545 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31546 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31547 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31548 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31549 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31550 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31551 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31552 * Weight of decay channel
31553 DATA (WT(K),K= 1, 85) /
31554 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31555 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31556 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31557 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31558 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31559 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31560 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31561 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31562 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31563 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31564 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31565 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31566 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31567 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31568 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31569 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31570 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31571 DATA (WT(K),K= 86,170) /
31572 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31573 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31574 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31575 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31576 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31577 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31578 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31579 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31580 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31581 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31582 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31583 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31584 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31585 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31586 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31587 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31588 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31589 DATA (WT(K),K=171,255) /
31590 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31591 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31592 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31593 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31594 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31595 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31596 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31597 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31598 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31599 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31600 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31601 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31602 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31603 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31604 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31605 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31606 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31607 DATA (WT(K),K=256,340) /
31608 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31609 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31610 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31611 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31612 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31613 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31614 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31615 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31616 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31617 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31618 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31619 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31620 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31621 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31622 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31623 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31624 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31625 DATA (WT(K),K=341,425) /
31626 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31627 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31628 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31629 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31630 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31631 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31632 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31633 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31634 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31635 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31636 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31637 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31638 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31639 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31640 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31641 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31642 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31643 DATA (WT(K),K=426,510) /
31644 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31645 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31646 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31647 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31648 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31649 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31650 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31651 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31652 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31653 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31654 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31655 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31656 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31657 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31658 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31659 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31660 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31661 DATA (WT(K),K=511,540) /
31662 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31663 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31664 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31665 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31666 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31667 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31669 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31670 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31671 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31672 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31673 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31674 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31675 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31676 * Particle numbers in decay channel
31677 DATA (NZK(K,1),K= 1,170) /
31678 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31679 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31680 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31681 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31682 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31683 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31684 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31685 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31686 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31687 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31688 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31689 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31690 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31691 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31692 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31693 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31694 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31695 DATA (NZK(K,1),K=171,340) /
31696 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31697 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31698 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31699 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31700 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31701 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31702 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31703 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31704 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31705 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31706 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31707 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31708 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31709 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31710 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31711 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31712 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31713 DATA (NZK(K,1),K=341,510) /
31714 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31715 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31716 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31717 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31718 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31719 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31720 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31721 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31722 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31723 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31724 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31725 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31726 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31727 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31728 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31729 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31730 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31731 DATA (NZK(K,1),K=511,540) /
31732 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31733 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31734 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31735 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31736 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31737 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31738 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31739 & 55, 8, 1, 8, 8, 54, 55, 210/
31740 DATA (NZK(K,2),K= 1,170) /
31741 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31742 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31743 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31744 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31745 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31746 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31747 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31748 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31749 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31750 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31751 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31752 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31753 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31754 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31755 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31756 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31757 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31758 DATA (NZK(K,2),K=171,340) /
31759 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31760 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31761 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31762 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31763 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31764 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31765 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31766 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31767 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31768 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31769 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31770 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31771 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31772 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31773 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31774 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31775 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31776 DATA (NZK(K,2),K=341,510) /
31777 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31778 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31779 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31780 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31781 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31782 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31783 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31784 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31785 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31786 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31787 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31788 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31789 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31790 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31791 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31792 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31793 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31794 DATA (NZK(K,2),K=511,540) /
31795 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31796 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31797 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31798 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31799 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31800 & 14, 14, 23, 14, 16, 25,
31801 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31802 & 23, 13, 14, 23, 0 /
31803 DATA (NZK(K,3),K= 1,170) /
31804 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31805 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31806 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31807 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31808 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31809 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31811 DATA (NZK(K,3),K=171,340) /
31813 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31814 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31815 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31816 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31817 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31819 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31820 DATA (NZK(K,3),K=341,510) /
31822 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31823 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31824 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31825 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31826 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31827 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31829 DATA (NZK(K,3),K=511,540) /
31830 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31831 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31832 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31833 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31834 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31838 *$ CREATE DT_BDEVAP.FOR
31841 *=== bdevap ===========================================================*
31843 BLOCK DATA DT_BDEVAP
31845 C INCLUDE '(DBLPRC)'
31847 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31849 * (original name: GLOBAL)
31850 PARAMETER ( KALGNM = 2 )
31851 PARAMETER ( ANGLGB = 5.0D-16 )
31852 PARAMETER ( ANGLSQ = 2.5D-31 )
31853 PARAMETER ( AXCSSV = 0.2D+16 )
31854 PARAMETER ( ANDRFL = 1.0D-38 )
31855 PARAMETER ( AVRFLW = 1.0D+38 )
31856 PARAMETER ( AINFNT = 1.0D+30 )
31857 PARAMETER ( AZRZRZ = 1.0D-30 )
31858 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31859 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31860 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31861 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31862 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
31863 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
31864 PARAMETER ( CSNNRM = 2.0D-15 )
31865 PARAMETER ( DMXTRN = 1.0D+08 )
31866 PARAMETER ( ZERZER = 0.D+00 )
31867 PARAMETER ( ONEONE = 1.D+00 )
31868 PARAMETER ( TWOTWO = 2.D+00 )
31869 PARAMETER ( THRTHR = 3.D+00 )
31870 PARAMETER ( FOUFOU = 4.D+00 )
31871 PARAMETER ( FIVFIV = 5.D+00 )
31872 PARAMETER ( SIXSIX = 6.D+00 )
31873 PARAMETER ( SEVSEV = 7.D+00 )
31874 PARAMETER ( EIGEIG = 8.D+00 )
31875 PARAMETER ( ANINEN = 9.D+00 )
31876 PARAMETER ( TENTEN = 10.D+00 )
31877 PARAMETER ( HLFHLF = 0.5D+00 )
31878 PARAMETER ( ONETHI = ONEONE / THRTHR )
31879 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31880 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31881 PARAMETER ( THRTWO = THRTHR / TWOTWO )
31882 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31883 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31884 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31885 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31886 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31887 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31888 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31889 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
31890 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
31891 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
31892 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
31893 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31894 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31895 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31896 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31897 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31898 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31899 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31900 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31901 PARAMETER ( CLIGHT = 2.99792458 D+10 )
31902 PARAMETER ( AVOGAD = 6.0221367 D+23 )
31903 PARAMETER ( BOLTZM = 1.380658 D-23 )
31904 PARAMETER ( AMELGR = 9.1093897 D-28 )
31905 PARAMETER ( PLCKBR = 1.05457266 D-27 )
31906 PARAMETER ( ELCCGS = 4.8032068 D-10 )
31907 PARAMETER ( ELCMKS = 1.60217733 D-19 )
31908 PARAMETER ( AMUGRM = 1.6605402 D-24 )
31909 PARAMETER ( AMMUMU = 0.113428913 D+00 )
31910 PARAMETER ( AMPRMU = 1.007276470 D+00 )
31911 PARAMETER ( AMNEMU = 1.008664904 D+00 )
31912 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31913 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31914 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31915 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31916 PARAMETER ( PLABRC = 0.197327053 D+00 )
31917 PARAMETER ( AMELCT = 0.51099906 D-03 )
31918 PARAMETER ( AMUGEV = 0.93149432 D+00 )
31919 PARAMETER ( AMMUON = 0.105658389 D+00 )
31920 PARAMETER ( AMPRTN = 0.93827231 D+00 )
31921 PARAMETER ( AMNTRN = 0.93956563 D+00 )
31922 PARAMETER ( AMDEUT = 1.87561339 D+00 )
31923 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31925 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31926 PARAMETER ( BLTZMN = 8.617385 D-14 )
31927 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31928 PARAMETER ( GFOHB3 = 1.16639 D-05 )
31929 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31930 PARAMETER ( SIN2TW = 0.2319 D+00 )
31931 PARAMETER ( GEVMEV = 1.0 D+03 )
31932 PARAMETER ( EMVGEV = 1.0 D-03 )
31933 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
31934 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31935 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31936 LOGICAL LGBIAS, LGBANA
31937 COMMON /FKGLOB/ LGBIAS, LGBANA
31938 C INCLUDE '(DIMPAR)'
31940 PARAMETER ( MXXRGN = 5000 )
31941 PARAMETER ( MXXMDF = 82 )
31942 PARAMETER ( MXXMDE = 54 )
31943 PARAMETER ( MFSTCK = 1000 )
31944 PARAMETER ( MESTCK = 100 )
31945 PARAMETER ( NELEMX = 80 )
31946 PARAMETER ( MPDPDX = 8 )
31947 PARAMETER ( ICOMAX = 180 )
31948 PARAMETER ( NSTBIS = 304 )
31949 PARAMETER ( IDMAXP = 220 )
31950 PARAMETER ( IDMXDC = 640 )
31951 PARAMETER ( MKBMX1 = 1 )
31952 PARAMETER ( MKBMX2 = 1 )
31953 C INCLUDE '(IOUNIT)'
31955 PARAMETER ( LUNIN = 5 )
31956 PARAMETER ( LUNOUT = 6 )
31957 **sr 19.5. set error output-unit from 15 to 6
31958 PARAMETER ( LUNERR = 6 )
31959 PARAMETER ( LUNBER = 14 )
31960 PARAMETER ( LUNECH = 8 )
31961 PARAMETER ( LUNFLU = 13 )
31962 PARAMETER ( LUNGEO = 16 )
31963 PARAMETER ( LUNPMF = 12 )
31964 PARAMETER ( LUNRAN = 2 )
31965 PARAMETER ( LUNXSC = 9 )
31966 PARAMETER ( LUNDET = 17 )
31967 PARAMETER ( LUNRAY = 10 )
31968 PARAMETER ( LUNRDB = 1 )
31969 PARAMETER ( LUNPGO = 7 )
31970 PARAMETER ( LUNPGS = 4 )
31971 PARAMETER ( LUNSCR = 3 )
31973 *----------------------------------------------------------------------*
31975 * Block Data for the EVAPoration routines: *
31977 * Created on 20 may 1990 by Alfredo Ferrari & Paola Sala *
31980 * Modified from the original version of J.M.Zazula *
31981 * and, for cookcm, from a LAHET block data kindly provided by *
31984 * Last change on 20-feb-95 by Alfredo Ferrari *
31987 *----------------------------------------------------------------------*
31989 * (original name: COOKCM)
31990 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
31991 LOGICAL LDEFOZ, LDEFON
31992 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
31993 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
31994 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
31995 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
31996 * (original name: EVA0)
31997 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
31998 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
31999 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32000 * T (4,7), RMASS (297), ALPH (297), BET (297),
32001 * APRIME (250), IA (6), IZ (6)
32002 * (original name: HETTP)
32003 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
32004 * (original name: HETC7)
32005 COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32006 * (original name: INPFLG)
32007 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32009 DATA B0 / 8.D+00 /, Y0 / 1.5D+00 /
32010 DATA IANG / 1 /, IFISS / 1 /, IB0 / 2 /, IGEOM / 0 /
32011 DATA ISTRAG /0/, KEYDK /0/
32012 DATA NBERTP /LUNBER/
32013 DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32016 DATA ( PZCOOK(I),I = 1, IZCOOK ) /
32017 & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32018 & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32019 & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32020 & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32021 & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32022 & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32023 & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32024 & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32025 & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32026 & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32027 &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32028 & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32029 & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32030 & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32031 & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32032 &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32033 & 0.000D+00, 7.700D-01/
32034 DATA ( PNCOOK(I),I = 1, 90 ) /
32035 & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32036 & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32037 & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32038 & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32039 & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32040 & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32041 &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32042 & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32043 & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32044 & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32045 &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32046 &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32047 &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32048 &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32049 &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32050 DATA ( PNCOOK(I),I = 91, INCOOK ) /
32051 &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32052 &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32053 & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32054 & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32055 &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32056 & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32057 & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32058 & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32059 & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32060 & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32061 DATA ( SZCOOK(I),I = 1, 98) /
32062 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32063 & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32064 &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32065 &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32066 &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32067 &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32068 &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32069 &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32070 &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32071 &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32072 &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32073 &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32074 &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32075 &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32076 &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32077 &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32078 &-7.200D+00,-7.740D+00/
32079 DATA ( SNCOOK(I),I = 1, 90 ) /
32080 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32081 & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32082 & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32083 & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32084 & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32085 & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32086 & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32087 & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32088 & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32089 & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32090 & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32091 & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32092 & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32093 & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32094 & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32095 DATA ( SNCOOK(I),I = 91, INCOOK ) /
32096 & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32097 & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32098 & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32099 & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32100 & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32101 & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32102 &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32103 & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32104 & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32105 & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32106 DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32107 DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32108 *=== End of Block Data Bdevap =========================================*
32111 *$ CREATE DT_BDNOPT.FOR
32114 *=== bdnopt ===========================================================*
32116 BLOCK DATA DT_BDNOPT
32118 C INCLUDE '(DBLPRC)'
32120 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32122 * (original name: GLOBAL)
32123 PARAMETER ( KALGNM = 2 )
32124 PARAMETER ( ANGLGB = 5.0D-16 )
32125 PARAMETER ( ANGLSQ = 2.5D-31 )
32126 PARAMETER ( AXCSSV = 0.2D+16 )
32127 PARAMETER ( ANDRFL = 1.0D-38 )
32128 PARAMETER ( AVRFLW = 1.0D+38 )
32129 PARAMETER ( AINFNT = 1.0D+30 )
32130 PARAMETER ( AZRZRZ = 1.0D-30 )
32131 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32132 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32133 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32134 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32135 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32136 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32137 PARAMETER ( CSNNRM = 2.0D-15 )
32138 PARAMETER ( DMXTRN = 1.0D+08 )
32139 PARAMETER ( ZERZER = 0.D+00 )
32140 PARAMETER ( ONEONE = 1.D+00 )
32141 PARAMETER ( TWOTWO = 2.D+00 )
32142 PARAMETER ( THRTHR = 3.D+00 )
32143 PARAMETER ( FOUFOU = 4.D+00 )
32144 PARAMETER ( FIVFIV = 5.D+00 )
32145 PARAMETER ( SIXSIX = 6.D+00 )
32146 PARAMETER ( SEVSEV = 7.D+00 )
32147 PARAMETER ( EIGEIG = 8.D+00 )
32148 PARAMETER ( ANINEN = 9.D+00 )
32149 PARAMETER ( TENTEN = 10.D+00 )
32150 PARAMETER ( HLFHLF = 0.5D+00 )
32151 PARAMETER ( ONETHI = ONEONE / THRTHR )
32152 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32153 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32154 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32155 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32156 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32157 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32158 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32159 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32160 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32161 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32162 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32163 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32164 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32165 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32166 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32167 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32168 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32169 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32170 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32171 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32172 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32173 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32174 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32175 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32176 PARAMETER ( BOLTZM = 1.380658 D-23 )
32177 PARAMETER ( AMELGR = 9.1093897 D-28 )
32178 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32179 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32180 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32181 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32182 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32183 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32184 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32185 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32186 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32187 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32188 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32189 PARAMETER ( PLABRC = 0.197327053 D+00 )
32190 PARAMETER ( AMELCT = 0.51099906 D-03 )
32191 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32192 PARAMETER ( AMMUON = 0.105658389 D+00 )
32193 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32194 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32195 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32196 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32198 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32199 PARAMETER ( BLTZMN = 8.617385 D-14 )
32200 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32201 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32202 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32203 PARAMETER ( SIN2TW = 0.2319 D+00 )
32204 PARAMETER ( GEVMEV = 1.0 D+03 )
32205 PARAMETER ( EMVGEV = 1.0 D-03 )
32206 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32207 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32208 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32209 LOGICAL LGBIAS, LGBANA
32210 COMMON /FKGLOB/ LGBIAS, LGBANA
32211 C INCLUDE '(DIMPAR)'
32213 PARAMETER ( MXXRGN = 5000 )
32214 PARAMETER ( MXXMDF = 82 )
32215 PARAMETER ( MXXMDE = 54 )
32216 PARAMETER ( MFSTCK = 1000 )
32217 PARAMETER ( MESTCK = 100 )
32218 PARAMETER ( NELEMX = 80 )
32219 PARAMETER ( MPDPDX = 8 )
32220 PARAMETER ( ICOMAX = 180 )
32221 PARAMETER ( NSTBIS = 304 )
32222 PARAMETER ( IDMAXP = 220 )
32223 PARAMETER ( IDMXDC = 640 )
32224 PARAMETER ( MKBMX1 = 1 )
32225 PARAMETER ( MKBMX2 = 1 )
32226 C INCLUDE '(IOUNIT)'
32228 PARAMETER ( LUNIN = 5 )
32229 PARAMETER ( LUNOUT = 6 )
32230 **sr 19.5. set error output-unit from 15 to 6
32231 PARAMETER ( LUNERR = 6 )
32232 PARAMETER ( LUNBER = 14 )
32233 PARAMETER ( LUNECH = 8 )
32234 PARAMETER ( LUNFLU = 13 )
32235 PARAMETER ( LUNGEO = 16 )
32236 PARAMETER ( LUNPMF = 12 )
32237 PARAMETER ( LUNRAN = 2 )
32238 PARAMETER ( LUNXSC = 9 )
32239 PARAMETER ( LUNDET = 17 )
32240 PARAMETER ( LUNRAY = 10 )
32241 PARAMETER ( LUNRDB = 1 )
32242 PARAMETER ( LUNPGO = 7 )
32243 PARAMETER ( LUNPGS = 4 )
32244 PARAMETER ( LUNSCR = 3 )
32246 *----------------------------------------------------------------------*
32248 * Created on 20 september 1989 by Alfredo Ferrari - Infn Milan *
32250 * Last change on 20-apr-95 by Alfredo Ferrari *
32252 *----------------------------------------------------------------------*
32254 C INCLUDE '(BLNKCM)'
32256 **sr 17.5. commented since not used here
32257 C PARAMETER ( NBLNMX = 1100000 )
32258 C DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32259 C & BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32260 C & COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32263 C COMMON NSTOR ( KALGNM*NBLNMX )
32265 **sr 18.5. commented since not used for evap.
32266 C COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32267 C & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32268 C & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32269 C & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32270 C & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32271 C & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32272 C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32273 C & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32274 C & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32275 C & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32279 C EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32280 C EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32281 C EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32282 C EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32283 C EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32284 C EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32285 C EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32286 C INCLUDE '(BLNTMP)'
32288 **sr 18.5. commented since not used for evap.
32289 C COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32290 C & KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32291 C & KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32294 C INCLUDE '(CMMDNR)'
32296 **sr 18.5. commented since not used for evap.
32298 C COMMON / CMMDNR / DDNEAR, LFLDNR
32300 C INCLUDE '(CTITLE)'
32302 **sr 18.5. commented since not used for evap.
32303 C CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32304 C COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32305 C COMMON / CEXPCK / ITEXPI, ITEXMX
32307 C INCLUDE '(DETECT)'
32309 **sr 18.5. commented since not used for evap.
32310 C PARAMETER (NRGNMX = 10)
32311 C PARAMETER (NDTCMX = 10)
32312 C PARAMETER (NSCRMX = 10)
32313 C PARAMETER (NDTBIN = 1024)
32314 C CHARACTER*10 TITDET,TITSCO
32316 C COMMON /DETCT/ EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32317 C & KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32318 C & NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32320 C COMMON /DETCH/ TITDET(NDTCMX), TITSCO(NSCRMX)
32322 C INCLUDE '(DETLOC)'
32324 **sr 18.5. commented since not used for evap.
32325 C PARAMETER (NDTCM2 = 10)
32326 C COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32327 C & ICOINC(NDTCM2), NCLAS
32329 C INCLUDE '(EMGTRN)'
32331 **sr 18.5. commented since not used for evap.
32333 C COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32335 C INCLUDE '(EMSHO)'
32337 **sr 18.5. commented since not used for evap.
32338 C LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32339 C COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32340 C & EMFHLO, EMFELO, LIMPRE, LEXPTE
32342 C INCLUDE '(EPISOR)'
32344 **sr 18.5. commented since not used for evap.
32346 C COMMON/EPISOR/TKESUM,LUSSRC
32348 * (original name: FHEAVY,FHEAVC)
32349 PARAMETER ( MXHEAV = 100 )
32351 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32352 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32353 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32354 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
32355 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
32356 & IBHEAV ( 12 ) , NPHEAV
32357 COMMON /FKFHVC/ ANHEAV ( 12 )
32358 * (original name: FINUC)
32359 PARAMETER (MXP=999)
32360 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
32361 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32362 & TKI (MXP), PLR (MXP), WEI (MXP),
32363 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32365 C INCLUDE '(GENTHR)'
32367 **sr 18.5. commented since not used for evap.
32368 C COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32369 C & PTHDFF (NALLWP), IJNUCR (NALLWP)
32371 C INCLUDE '(LOWNEU)'
32373 **sr 18.5. commented since not used for evap.
32374 C PARAMETER ( MXGTHN = 15 )
32375 C PARAMETER ( MXGLWN = 200 )
32376 C PARAMETER ( MXSHPP = 5 )
32377 C LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32378 C CHARACTER*10 TITLOW
32379 C COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32380 C & SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32381 C & VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32382 C & STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32383 C & TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32384 C & IGTMRT (MXXMDF), NEUMED (MXXMDF),
32385 C & ID1MED (MXXMDF), ID2MED (MXXMDF),
32386 C & ID3MED (MXXMDF), MGTMED (MXXMDF),
32387 C & LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32388 C & NMTG , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32389 C & LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32390 C & I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32391 C & IWWLWT, IPXBGN, NPXSEC
32392 C COMMON / CHLWNT / TITLOW (MXXMDF)
32394 C INCLUDE '(LTCLCM)'
32396 **sr 18.5. commented since not used for evap.
32397 C COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32399 C INCLUDE '(MULBOU)'
32401 **sr 18.5. commented since not used for evap.
32402 C LOGICAL LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32403 C COMMON / MULBOU / UOLD , VOLD , WOLD , UMAG , VMAG , WMAG ,
32404 C & UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32405 C & TSENSE, DDSENS, DSMALL, NSSENS, LLDA , LAGAIN,
32406 C & LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32408 C INCLUDE '(MULHD)'
32410 **sr 18.5. commented since not used for evap.
32411 C PARAMETER ( MXXPT1 = 1 )
32412 C PARAMETER ( TIMESS = 2.00D+00 )
32413 C PARAMETER ( TMSRLX = 1.50D+00 )
32414 C PARAMETER ( EPSINS = 0.15D+00 )
32415 C PARAMETER ( EPSRLX = 0.50D+00 )
32416 C PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32417 C PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32418 C PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32419 C PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32420 C PARAMETER ( R0NCMS = 1.20 D+00 )
32421 C LOGICAL LTOPT, LSRCRH, LNSCRH
32422 C COMMON / MULHD / BLCC ( MXXMDF ), BLCCRA ( MXXMDF ),
32423 C & XCC ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32424 C & ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU ( MXXMDF ),
32425 C & ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0 ( MXXMDF ),
32426 C & XR0 ( MXXMDF ), ECUTM ( MXXMDF, 39, 2 ),
32427 C & ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32428 C & AE1O3 ( MXXMDF ), PARNSR ( MXXMDF ),
32429 C & HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32430 C & HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32431 C & LTOPT ( MXXMDF ), NFSCAT
32433 * (original name: PAREVT)
32434 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32435 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32436 PARAMETER ( NALLWP = 39 )
32437 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32438 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32439 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32440 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32441 * (original name: RESNUC)
32442 LOGICAL LRNFSS, LFRAGM
32443 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32444 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32445 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
32446 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
32447 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32448 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32449 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32450 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32452 C INCLUDE '(SCOHLP)'
32454 **sr 18.5. commented since not used for evap.
32456 C COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32458 C INCLUDE '(TRACKR)'
32460 **sr 18.5. commented since not used for evap.
32461 C PARAMETER ( MXTRCK = 2500 )
32463 C COMMON / TRACKR / XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32464 C & ZTRACK ( 0:MXTRCK ), TTRACK ( MXTRCK ),
32465 C & DTRACK ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32466 C & ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32467 C & NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32468 C & LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32470 C INCLUDE '(USRBDX)'
32472 **sr 18.5. commented since not used for evap.
32473 C PARAMETER ( MXUSBX = 600 )
32474 C LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32475 C CHARACTER*10 TITUSX
32476 C COMMON /USRBX/ EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32477 C & ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32478 C & AUSBDX(MXUSBX),
32479 C & NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32480 C & NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32481 C & KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32482 C & LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32484 C COMMON /USXCH/ TITUSX(MXUSBX)
32486 C INCLUDE '(USRBIN)'
32488 **sr 18.5. commented since not used for evap.
32489 C PARAMETER ( MXUSBN = 100 )
32490 C LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32491 C CHARACTER*10 TITUSB
32492 C COMMON /USRBN/ XLOW (MXUSBN), XHIGH (MXUSBN), YLOW (MXUSBN),
32493 C & YHIGH (MXUSBN), ZLOW (MXUSBN), ZHIGH (MXUSBN),
32494 C & DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32495 C & TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32496 C & NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32497 C & ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32498 C & IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32499 C & LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32500 C COMMON /USRCH/ TITUSB(MXUSBN)
32502 C INCLUDE '(USRSNC)'
32504 **sr 18.5. commented since not used for evap.
32505 C PARAMETER ( MXRSNC = 400 )
32506 C PARAMETER ( NMZMIN = -5 )
32508 C CHARACTER*10 TIURSN
32509 C COMMON /USRSNC/ VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32510 C & NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32511 C & IPURSN(MXRSNC), NURSNC, LURSNC
32512 C COMMON /USRSCH/ TIURSN(MXRSNC)
32513 C INCLUDE '(USRTRC)'
32515 **sr 18.5. commented since not used for evap.
32516 C PARAMETER ( MXUSTC = 400 )
32517 C LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32518 C CHARACTER*10 TITUTC
32519 C COMMON /USRTC/ ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32520 C & VUSRTC(MXUSTC),
32521 C & IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32522 C & NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32523 C & KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32524 C & LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32526 C COMMON /USTCH/ TITUTC(MXUSTC)
32528 C INCLUDE '(USRYLD)'
32530 **sr 18.5. commented since not used for evap.
32531 C PARAMETER ( MXUSYL = 500 )
32532 C LOGICAL LUSRYL, LLNUYL, LSCUYL
32533 C CHARACTER*10 TITUYL
32534 C COMMON /USRYL/ EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32535 C & USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32536 C & AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32537 C & ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32538 C & VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32539 C & NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32540 C & IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32541 C & KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32542 C & IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32543 C & NUSRYL, LUSRYL, LSCUYL
32544 C COMMON /USYCH/ TITUYL(MXUSYL)
32546 C INCLUDE '(WWINDW)'
32548 **sr 18.5. commented since not used for evap.
32549 C PARAMETER ( MXWWSP = 3 )
32550 C PARAMETER ( WWSPMX = 50.D+00 )
32551 C LOGICAL LWWNDW, LWWPRM
32552 C COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32553 C & WWEXWD (NALLWP), EXTWWN (NALLWP),
32554 C & IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32558 * *** If blank common dimension has to be superseded substitute in the
32559 * *** following two lines the new dimension in real*8 units to Nblnmx
32560 **sr 18.5. commented since not used for evap.
32561 C PARAMETER (MXDUMM = KALGNM * NBLNMX)
32562 C DATA KTMBGN / NBLNMX /
32563 C DATA MBLNMX / MXDUMM /
32564 C DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32565 C & KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32566 C & KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32567 C & KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32568 C & KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32569 C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32570 C & KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32571 C & KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32572 C & KBRLST / 57*0 /
32575 **sr 18.5. commented since not used for evap.
32576 C DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32577 C & KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32578 C & KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32581 **sr 18.5. commented since not used for evap.
32582 C DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32585 **sr 18.5. commented since not used for evap.
32586 C DATA RUNTIT (1:40) / '****************************************' /
32587 C DATA RUNTIT(41:80) / '****************************************' /
32588 C DATA ITEXPI, ITEXMX / 100000000, 150 /
32590 **sr 18.5. commented since not used for evap.
32591 C PARAMETER (NNN1 = NRGNMX*NDTCMX)
32592 C PARAMETER (NNN2 = NSCRMX*NDTCMX)
32593 C DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32594 C DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32595 C DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32596 C DATA TITDET/NDTCMX*' '/, TITSCO/NSCRMX*' '/
32599 **sr 18.5. commented since not used for evap.
32600 C DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32604 **sr 18.5. commented since not used for evap.
32605 C DATA LMCSMG / .FALSE. /
32608 **sr 18.5. commented since not used for evap.
32609 C DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32612 **sr 18.5. commented since not used for evap.
32613 C DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32616 DATA AMHEAV / 12 * 0.D+00 /
32617 DATA ANHEAV / 'NEUTRON ', 'PROTON ', 'DEUTERON', '3-H ',
32618 & '3-He ', '4-He ', 'H-FRAG-1', 'H-FRAG-2',
32619 & 'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32620 DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32621 & IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32625 DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32626 & TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32630 * DATA PEANCT, PEAPIT / 2*1.D+00 /
32631 * DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32633 * DATA PTHDFF / 39*5.D+00 /
32636 **sr 18.5. commented since not used for evap.
32637 C DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32638 C DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32639 C & 3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32641 C DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32642 C & 3.5D+00, 13*5.D+00 /
32643 C DATA PLDNCT / 0.26D+00 /
32644 C DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32647 **sr 18.5. commented since not used for evap.
32648 C DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32649 C DATA IWWLWB, IWWLWT / 2 * 100000000 /
32650 C DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32651 C DATA IGRTHN / 1 /
32652 C DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32653 C & LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32656 **sr 18.5. commented since not used for evap.
32657 C DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32660 **sr 18.5. commented since not used for evap.
32661 C DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32662 C & / 7 * .FALSE. /
32663 C DATA TSENSE / AINFNT /, NSSENS / -1 /
32664 C DATA DSMALL / ANGLGB /
32667 **sr 18.5. commented since not used for evap.
32668 C DATA LTOPT / MXXMDF * .FALSE. /, NFSCAT / 0 /
32669 C DATA ESTEPF / MXXMDF * 0.1D+00 /
32670 C DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32671 C DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32674 DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32675 & RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32676 DATA LDIFFR / .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32677 & .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32678 & 4 * .FALSE., 9 * .TRUE./
32680 * default value for LEVPRT changed (reset sr 25.7.97)
32681 * default value for LHEAVY changed 25.7.97
32682 C DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32683 C & LHEAVY / .FALSE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32684 C & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32685 C & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32686 DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32687 & LHEAVY / .TRUE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32688 & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32689 & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32692 * default value for ILVMOD changed
32693 C DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32694 DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32698 DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32700 DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32701 & IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32703 DATA LRNFSS / .FALSE. /
32706 **sr 18.5. commented since not used for evap.
32707 C DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32710 **sr 18.5. commented since not used for evap.
32711 C DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32712 C & CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32715 **sr 18.5. commented since not used for evap.
32716 C DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32719 **sr 18.5. commented since not used for evap.
32720 C DATA LUSBDX /.FALSE./, NUSRBX /0/
32723 **sr 18.5. commented since not used for evap.
32724 C DATA LURSNC /.FALSE./, NURSNC /0/
32727 **sr 18.5. commented since not used for evap.
32728 C DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32729 C DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32732 **sr 18.5. commented since not used for evap.
32733 C DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32734 C & IJUSYL /0/, JTUSYL /0/
32735 C DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32738 **sr 18.5. commented since not used for evap.
32739 C DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32740 C DATA LWWPRM / .TRUE. /
32742 *= end*block.bdnopt *
32745 *$ CREATE DT_BDPREE.FOR
32748 *=== bdpree ===========================================================*
32750 BLOCK DATA DT_BDPREE
32752 C INCLUDE '(DBLPRC)'
32754 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32756 * (original name: GLOBAL)
32757 PARAMETER ( KALGNM = 2 )
32758 PARAMETER ( ANGLGB = 5.0D-16 )
32759 PARAMETER ( ANGLSQ = 2.5D-31 )
32760 PARAMETER ( AXCSSV = 0.2D+16 )
32761 PARAMETER ( ANDRFL = 1.0D-38 )
32762 PARAMETER ( AVRFLW = 1.0D+38 )
32763 PARAMETER ( AINFNT = 1.0D+30 )
32764 PARAMETER ( AZRZRZ = 1.0D-30 )
32765 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32766 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32767 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32768 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32769 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32770 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32771 PARAMETER ( CSNNRM = 2.0D-15 )
32772 PARAMETER ( DMXTRN = 1.0D+08 )
32773 PARAMETER ( ZERZER = 0.D+00 )
32774 PARAMETER ( ONEONE = 1.D+00 )
32775 PARAMETER ( TWOTWO = 2.D+00 )
32776 PARAMETER ( THRTHR = 3.D+00 )
32777 PARAMETER ( FOUFOU = 4.D+00 )
32778 PARAMETER ( FIVFIV = 5.D+00 )
32779 PARAMETER ( SIXSIX = 6.D+00 )
32780 PARAMETER ( SEVSEV = 7.D+00 )
32781 PARAMETER ( EIGEIG = 8.D+00 )
32782 PARAMETER ( ANINEN = 9.D+00 )
32783 PARAMETER ( TENTEN = 10.D+00 )
32784 PARAMETER ( HLFHLF = 0.5D+00 )
32785 PARAMETER ( ONETHI = ONEONE / THRTHR )
32786 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32787 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32788 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32789 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32790 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32791 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32792 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32793 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32794 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32795 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32796 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32797 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32798 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32799 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32800 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32801 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32802 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32803 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32804 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32805 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32806 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32807 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32808 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32809 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32810 PARAMETER ( BOLTZM = 1.380658 D-23 )
32811 PARAMETER ( AMELGR = 9.1093897 D-28 )
32812 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32813 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32814 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32815 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32816 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32817 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32818 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32819 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32820 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32821 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32822 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32823 PARAMETER ( PLABRC = 0.197327053 D+00 )
32824 PARAMETER ( AMELCT = 0.51099906 D-03 )
32825 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32826 PARAMETER ( AMMUON = 0.105658389 D+00 )
32827 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32828 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32829 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32830 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32832 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32833 PARAMETER ( BLTZMN = 8.617385 D-14 )
32834 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32835 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32836 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32837 PARAMETER ( SIN2TW = 0.2319 D+00 )
32838 PARAMETER ( GEVMEV = 1.0 D+03 )
32839 PARAMETER ( EMVGEV = 1.0 D-03 )
32840 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32841 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32842 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32843 LOGICAL LGBIAS, LGBANA
32844 COMMON /FKGLOB/ LGBIAS, LGBANA
32845 C INCLUDE '(DIMPAR)'
32847 PARAMETER ( MXXRGN = 5000 )
32848 PARAMETER ( MXXMDF = 82 )
32849 PARAMETER ( MXXMDE = 54 )
32850 PARAMETER ( MFSTCK = 1000 )
32851 PARAMETER ( MESTCK = 100 )
32852 PARAMETER ( NALLWP = 39 )
32853 PARAMETER ( NELEMX = 80 )
32854 PARAMETER ( MPDPDX = 8 )
32855 PARAMETER ( ICOMAX = 180 )
32856 PARAMETER ( NSTBIS = 304 )
32857 PARAMETER ( IDMAXP = 220 )
32858 PARAMETER ( IDMXDC = 640 )
32859 PARAMETER ( MKBMX1 = 1 )
32860 PARAMETER ( MKBMX2 = 1 )
32861 C INCLUDE '(IOUNIT)'
32863 PARAMETER ( LUNIN = 5 )
32864 PARAMETER ( LUNOUT = 6 )
32865 **sr 19.5. set error output-unit from 15 to 6
32866 PARAMETER ( LUNERR = 6 )
32867 PARAMETER ( LUNBER = 14 )
32868 PARAMETER ( LUNECH = 8 )
32869 PARAMETER ( LUNFLU = 13 )
32870 PARAMETER ( LUNGEO = 16 )
32871 PARAMETER ( LUNPMF = 12 )
32872 PARAMETER ( LUNRAN = 2 )
32873 PARAMETER ( LUNXSC = 9 )
32874 PARAMETER ( LUNDET = 17 )
32875 PARAMETER ( LUNRAY = 10 )
32876 PARAMETER ( LUNRDB = 1 )
32877 PARAMETER ( LUNPGO = 7 )
32878 PARAMETER ( LUNPGS = 4 )
32879 PARAMETER ( LUNSCR = 3 )
32881 *----------------------------------------------------------------------*
32883 * Created on 16 september 1991 by Alfredo Ferrari & Paola Sala *
32886 * Last change on 03-feb-94 by Alfredo Ferrari *
32889 *----------------------------------------------------------------------*
32891 * (original name: CMPISG,CHPISG)
32892 PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32893 PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32894 PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32895 PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32896 PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32897 PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32898 PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32899 PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32900 PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32901 PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32902 PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32903 PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32904 PARAMETER ( PIRSMX = 1.2D+00 )
32905 PARAMETER ( NPIREA = 10 )
32906 PARAMETER ( NPIRTA = 68 )
32907 PARAMETER ( NPIRLN = 21 )
32908 PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32909 PARAMETER ( NPISIS = NPIRLN + 20 )
32910 PARAMETER ( NPISEX = NPIRLN + 21 )
32911 PARAMETER ( NPIIMN = 14 )
32912 PARAMETER ( NPIIRC = 6 )
32913 PARAMETER ( DELWLL = 0.035D+00 )
32916 COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32917 & RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32918 & ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32919 & CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32920 & SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32921 & SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5) ,
32922 & SGPICU (0:20,NPIRTA,NPIREA) , SGRTRS (NPIREA),
32923 & SGPIDF (0:20,NPIRTA,NPIREA) , BRREIN (NPIREA),
32924 & SGPIIS (NPIRTA,NPIREA) , BRREOU (NPIREA),
32925 & BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32926 & SGABSR (2,2,4) , PRRSDL,
32927 & IPIREA (2,2,3:5) , IPIINE (2,3:5) , NPIRVR ,
32928 & KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32929 & JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32930 COMMON /FKCHPI/ CHPIRE (NPIREA)
32931 DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32932 EQUIVALENCE ( SG2BRS (1,1), SGABSR (1,1,1) )
32933 EQUIVALENCE ( SGABSW (1,1), SGABSR (1,1,2) )
32934 EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32935 * (original name: FRBKCM)
32936 PARAMETER ( MXFFBK = 6 )
32937 PARAMETER ( MXZFBK = 9 )
32938 PARAMETER ( MXNFBK = 10 )
32939 PARAMETER ( MXAFBK = 16 )
32940 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32941 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32942 PARAMETER ( NXAFBK = MXAFBK + 1 )
32943 PARAMETER ( MXPSST = 300 )
32944 PARAMETER ( MXPSFB = 41000 )
32945 LOGICAL LFRMBK, LNCMSS
32946 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
32947 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
32948 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
32949 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
32950 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
32951 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
32952 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
32953 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
32954 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
32955 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
32956 PARAMETER ( PI = PIPIPI )
32957 PARAMETER ( PISQ = PIPISQ )
32958 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
32959 PARAMETER ( RZNUCL = 1.12 D+00 )
32960 PARAMETER ( RMSPRO = 0.8 D+00 )
32961 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
32962 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
32964 PARAMETER ( RLLE04 = RZNUCL )
32965 PARAMETER ( RLLE16 = RZNUCL )
32966 PARAMETER ( RLGT16 = RZNUCL )
32967 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
32968 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
32969 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
32970 PARAMETER ( SKLE04 = 1.4D+00 )
32971 PARAMETER ( SKLE16 = 1.9D+00 )
32972 PARAMETER ( SKGT16 = 2.4D+00 )
32973 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
32974 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
32975 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
32976 PARAMETER ( ALPHA0 = 0.1D+00 )
32977 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
32978 PARAMETER ( GAMSK0 = 0.9D+00 )
32979 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
32980 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
32981 PARAMETER ( POTBA0 = 1.D+00 )
32982 PARAMETER ( PNFRAT = 1.533D+00 )
32983 PARAMETER ( RADPIM = 0.035D+00 )
32984 PARAMETER ( RDPMHL = 14.D+00 )
32985 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
32986 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
32987 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
32988 PARAMETER ( AP0PFS = 0.5D+00 )
32989 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
32990 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
32991 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
32992 PARAMETER ( MXSCIN = 50 )
32993 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
32994 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
32995 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
32996 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
32997 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
32998 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
33000 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33001 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33002 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33003 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33004 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33005 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33006 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33007 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33008 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33009 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33010 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33011 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33012 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33013 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33014 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33015 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33016 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33017 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33018 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33019 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33020 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33021 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33022 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33023 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33024 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33025 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
33026 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33027 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33028 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33029 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33030 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33031 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33032 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33033 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33034 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33035 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33036 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33037 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33038 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33039 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33041 DIMENSION AWSTAB (2:260), SIGMAB (3)
33042 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33043 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33044 EQUIVALENCE ( RHOIPP, RHONCP (1) )
33045 EQUIVALENCE ( RHOINP, RHONCP (2) )
33046 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33047 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33048 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33049 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33050 EQUIVALENCE ( RHOIPT, RHONCT (1) )
33051 EQUIVALENCE ( RHOINT, RHONCT (2) )
33052 EQUIVALENCE ( OMALHL, SK3PAR )
33053 EQUIVALENCE ( ALPHAL, HABPAR )
33054 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33055 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33056 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33057 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33058 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33059 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33060 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33061 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33062 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33063 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33064 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33065 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33066 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33067 * (original name: NUCLEV)
33068 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33069 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33070 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33071 & CUMRAD (0:160,2), RUSNUC (2),
33072 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33073 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33074 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33075 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33076 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33077 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33078 & LFLVSL, LRLVSL, LEQSBL
33079 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33080 & MGSSPR (19) , MGSSNE (25)
33081 EQUIVALENCE ( RUSNUC (1), RUSPRO )
33082 EQUIVALENCE ( RUSNUC (2), RUSNEU )
33083 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33084 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33085 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33086 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33087 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33088 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33089 EQUIVALENCE ( NTANUC (1), NTAPRO )
33090 EQUIVALENCE ( NTANUC (2), NTANEU )
33091 EQUIVALENCE ( NAVNUC (1), NAVPRO )
33092 EQUIVALENCE ( NAVNUC (2), NAVNEU )
33093 EQUIVALENCE ( NLSNUC (1), NLSPRO )
33094 EQUIVALENCE ( NLSNUC (2), NLSNEU )
33095 EQUIVALENCE ( NCONUC (1), NCOPRO )
33096 EQUIVALENCE ( NCONUC (2), NCONEU )
33097 EQUIVALENCE ( NSKNUC (1), NSKPRO )
33098 EQUIVALENCE ( NSKNUC (2), NSKNEU )
33099 EQUIVALENCE ( NHANUC (1), NHAPRO )
33100 EQUIVALENCE ( NHANUC (2), NHANEU )
33101 EQUIVALENCE ( NUSNUC (1), NUSPRO )
33102 EQUIVALENCE ( NUSNUC (2), NUSNEU )
33103 EQUIVALENCE ( NACNUC (1), NACPRO )
33104 EQUIVALENCE ( NACNUC (2), NACNEU )
33105 EQUIVALENCE ( JMXNUC (1), JMXPRO )
33106 EQUIVALENCE ( JMXNUC (2), JMXNEU )
33107 EQUIVALENCE ( MAGNUC (1), MAGPRO )
33108 EQUIVALENCE ( MAGNUC (2), MAGNEU )
33109 * (original name: PARNUC)
33110 PARAMETER ( PIGRK = PIPIPI )
33111 PARAMETER ( ALEVEL = 8.D-03 )
33112 PARAMETER ( RCNUCL = 1.12D+00 )
33113 PARAMETER ( R0SIG = 1.3D+00 )
33114 PARAMETER ( R0SIGK = 1.5D+00 )
33115 PARAMETER ( RCOULB = 1.5D+00 )
33116 PARAMETER ( COULBH = 0.88235D-03 )
33117 PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33118 PARAMETER ( TAUFO0 = 10.0D+00 )
33119 PARAMETER ( EKEEXP = 0.03D+00 )
33120 PARAMETER ( EKREXP = 0.05D+00 )
33121 PARAMETER ( EKEMNM = 0.01D+00 )
33122 PARAMETER ( NCPMX = 120 )
33123 COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33124 & ENNUC (NCPMX), PNUCL (NCPMX), EKFNUC (NCPMX),
33125 & XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33126 & PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33127 & RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33128 & CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33129 & TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33130 & KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33131 & INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33132 & IBNUCL, NPNUC , NNUCTS
33134 DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33135 DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33136 DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33137 DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33138 DATA LPREEQ / .FALSE. /
33140 DATA JSTOKP / 1, 8, 13, 14, 23 /
33141 DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33142 DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33143 & 'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33144 & 'PI0NPI0N','PI0NPI-P' /
33145 DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33146 & 13, 8, 13, 8, 23, 8, 23, 8 /
33147 DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33148 & 13, 8, 23, 1, 23, 8, 14, 1 /
33149 DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33150 DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33152 DATA LFRMBK / .FALSE. /
33153 DATA NBUFBK / 500 /
33154 DATA EXMXFB / 80.0 D+00 /
33155 DATA R0FRBK / 1.18 D+00 /
33156 DATA R0CFBK / 2.173D+00 /
33157 DATA C1CFBK / 6.103D-03 /
33158 DATA C2CFBK / 9.443D-03 /
33160 DATA TAUFOR / TAUFO0 /
33161 *=== End of Block Data Bdpree =========================================*
33164 *$ CREATE DT_XHOINI.FOR
33167 *====phoini============================================================*
33169 SUBROUTINE DT_XHOINI
33170 C SUBROUTINE DT_PHOINI
33172 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33174 PARAMETER ( LINP = 10 ,
33181 *$ CREATE DT_XVENTB.FOR
33184 *====eventb============================================================*
33186 SUBROUTINE DT_XVENTB(NCSY,IREJ)
33187 C SUBROUTINE DT_EVENTB(NCSY,IREJ)
33189 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33191 PARAMETER ( LINP = 10 ,
33196 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
33201 *$ CREATE DT_XVENT.FOR
33204 *===event==============================================================*
33206 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33207 C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33209 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33212 DIMENSION PP(4),PT(4)
33217 *$ CREATE DT_XOHISX.FOR
33220 *===pohisx=============================================================*
33222 SUBROUTINE DT_XOHISX(I,X)
33223 C SUBROUTINE POHISX(I,X)
33225 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33231 *$ CREATE PHO_LHIST.FOR
33234 *===poluhi=============================================================*
33236 SUBROUTINE PHO_LHIST(I,X)
33239 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33245 *$ CREATE PDFSET.FOR
33248 C**********************************************************************
33250 C dummy subroutines, remove to link PDFLIB
33252 C**********************************************************************
33253 SUBROUTINE PDFSET(PARAM,VALUE)
33254 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33255 DIMENSION PARAM(20),VALUE(20)
33259 *$ CREATE STRUCTM.FOR
33262 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33263 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33266 *$ CREATE STRUCTP.FOR
33269 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33270 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33273 *$ CREATE DT_DIQBRK.FOR
33276 *===diqbrk=============================================================*
33278 SUBROUTINE DT_XIQBRK
33279 C SUBROUTINE DT_DIQBRK
33281 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33284 STOP 'diquark-breaking not implemeted !'
33289 *$ CREATE DT_ELHAIN.FOR
33292 *===elhain=============================================================*
33294 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33296 ************************************************************************
33297 * Elastic hadron-hadron scattering. *
33298 * This is a revised version of the original. *
33299 * This version dated 03.04.98 is written by S. Roesler *
33300 ************************************************************************
33302 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33304 PARAMETER ( LINP = 10 ,
33307 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33310 PARAMETER (ENNTHR = 3.5D0)
33311 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33312 & BLOWB=0.05D0,BHIB=0.2D0,
33313 & BLOWM=0.1D0, BHIM=2.0D0)
33315 * particle properties (BAMJET index convention)
33317 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33318 & IICH(210),IIBAR(210),K1(210),K2(210)
33319 * final state from HADRIN interaction
33320 PARAMETER (MAXFIN=10)
33321 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33322 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33324 C DATA TSLOPE /10.0D0/
33330 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33331 EKIN = ELAB-AAM(IP)
33332 * kinematical quantities in cms of the hadrons
33335 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
33337 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33338 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33340 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33341 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33342 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33343 * TSAMCS treats pp and np only, therefore change pn into np and
33349 IF (IP.EQ.8) KPROJ = 1
33351 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33352 T = TWO*PCM**2*(CTCMS-ONE)
33354 * very crude treatment otherwise: sample t from exponential dist.
33356 * momentum transfer t
33357 TMAX = TWO*TWO*PCM**2
33358 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33359 IF (IIBAR(IP).NE.0) THEN
33360 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33362 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33364 FMAX = EXP(-TSLOPE*TMAX)-ONE
33366 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33367 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33370 * target hadron in Lab after scattering
33371 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33372 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33373 IF (PLRH(2).LE.TINY10) THEN
33374 C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33377 * projectile hadron in Lab after scattering
33378 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33379 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33380 * scattering angle of projectile in Lab
33381 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33382 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33383 CALL DT_DSFECF(SPLABP,CPLABP)
33384 * direction cosines of projectile in Lab
33385 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33386 & CXRH(1),CYRH(1),CZRH(1))
33387 * scattering angle of target in Lab
33388 PLLABT = PLAB-CTLABP*PLRH(1)
33389 CTLABT = PLLABT/PLRH(2)
33390 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33391 * direction cosines of target in Lab
33392 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33393 & CXRH(2),CYRH(2),CZRH(2))
33402 *$ CREATE DT_TSAMCS.FOR
33405 *===tsamcs=============================================================*
33407 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33409 ************************************************************************
33410 * Sampling of cos(theta) for nucleon-proton scattering according to *
33411 * hetkfa2/bertini parametrization. *
33412 * This is a revised version of the original (HJM 24/10/88) *
33413 * This version dated 28.10.95 is written by S. Roesler *
33414 ************************************************************************
33416 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33418 PARAMETER ( LINP = 10 ,
33421 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33424 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33425 DIMENSION PDCI(60),PDCH(55)
33427 DATA (DCLIN(I),I=1,80) /
33428 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
33429 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
33430 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
33431 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
33432 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
33433 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
33434 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
33435 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
33436 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
33437 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
33438 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
33439 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
33440 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
33441 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
33442 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
33443 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
33444 DATA (DCLIN(I),I=81,160) /
33445 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
33446 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
33447 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
33448 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
33449 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
33450 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
33451 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
33452 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
33453 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
33454 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
33455 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
33456 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
33457 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
33458 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
33459 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
33460 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
33461 DATA (DCLIN(I),I=161,195) /
33462 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
33463 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
33464 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
33465 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
33466 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
33467 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
33468 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
33471 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
33472 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
33473 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
33474 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
33475 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
33476 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
33477 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
33478 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
33479 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
33480 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
33481 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
33482 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
33485 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
33486 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
33487 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
33488 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
33489 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
33490 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
33491 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
33492 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
33493 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
33494 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
33495 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
33497 DATA (DCHN(I),I=1,90) /
33498 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
33499 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
33500 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
33501 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
33502 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
33503 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
33504 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
33505 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
33506 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
33507 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
33508 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
33509 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
33510 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
33511 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
33512 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
33513 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
33514 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
33515 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
33516 DATA (DCHN(I),I=91,143) /
33517 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
33518 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
33519 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
33520 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
33521 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
33522 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
33523 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
33524 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
33525 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
33526 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
33527 & 6.488D-02, 6.485D-02, 6.480D-02/
33530 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
33531 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
33532 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
33533 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
33534 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
33535 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
33536 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
33540 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
33541 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
33542 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
33543 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
33544 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
33545 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
33546 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33547 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
33548 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33549 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
33550 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33551 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
33554 IF (EKIN.GT.3.5D0) RETURN
33556 IF(KPROJ.EQ.8) GOTO 101
33557 IF(KPROJ.EQ.1) GOTO 102
33558 C* INVALID REACTION
33559 WRITE(LOUT,'(A,I5/A)')
33560 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33561 & ' COS(THETA) = 1D0 RETURNED'
33563 C-------------------------------- NP ELASTIC SCATTERING----------
33565 IF (EKIN.GT.0.740D0)GOTO 1000
33566 IF (EKIN.LT.0.300D0)THEN
33567 C EKIN .LT. 300 MEV
33570 C 300 MEV < EKIN < 740 MEV
33575 IE=INT(ABS(ENER/0.020D0))
33576 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33577 C FORWARD/BACKWARD DECISION
33579 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33580 IF (DT_RNDM(CST).LT.BWFW)THEN
33588 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33591 IF(RND.LT.COEF)THEN
33600 IF(VALUE2.GT.0.0)THEN
33601 CST=MAX(R1,R2,R3,R4)
33607 CST=-MAX(R1,R2,R3,R4,R5)
33611 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33620 C******** EKIN .GT. 0.74 GEV
33622 1000 ENER=EKIN - 0.66D0
33623 C IE=ABS(ENER/0.02)
33624 IE=INT(ENER/0.02D0)
33627 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33629 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33632 IF (RND.GE.BWFW)THEN
33634 IF (DCHNA(K).GT.EMEV) THEN
33635 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33636 UNIV=DT_RNDM(UNIVE)
33639 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33642 UNIV=DT_RNDM(UNIVE)
33644 GOTO(290,290,290,290,330,340,350,360) I
33653 IF (DCHNB(K).GT.EMEV) THEN
33654 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33655 UNIV=DT_RNDM(UNIVE)
33658 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33663 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33670 120 CST=1.0D-2*FLTI-1.0D0
33672 140 CST=2.0D-2*UNIV-0.98D0
33674 150 CST=4.0D-2*UNIV-0.96D0
33676 160 CST=6.0D-2*FLTI-1.16D0
33678 180 CST=8.0D-2*UNIV-0.80D0
33680 190 CST=1.0D-1*UNIV-0.72D0
33682 200 CST=1.2D-1*UNIV-0.62D0
33684 210 CST=2.0D-1*UNIV-0.50D0
33686 220 CST=3.0D-1*(UNIV-1.0D0)
33689 290 CST=1.0D0-2.5d-2*FLTI
33691 330 CST=0.85D0+0.5D-1*UNIV
33693 340 CST=0.70D0+1.5D-1*UNIV
33695 350 CST=0.50D0+2.0D-1*UNIV
33697 360 CST=0.50D0*UNIV
33701 C----------------------------------- PP ELASTIC SCATTERING -------
33706 IF (EKIN.LE.0.500D0) THEN
33708 CST=2.0D0*RND-1.0D0
33711 ELSEIF (EKIN.LT.1.0D0) THEN
33713 IF (PDCI(K).GT.EMEV) THEN
33714 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33715 UNIV=DT_RNDM(UNIVE)
33719 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33721 IF (UNIV.LT.SUM)THEN
33724 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33731 IF (PDCH(K).GT.EMEV) THEN
33732 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33733 UNIV=DT_RNDM(UNIVE)
33737 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33739 IF (UNIV.LT.SUM)THEN
33742 GOTO(50,55,60,60,65,65,65,65,70,70) I
33753 60 CST=0.3D0+0.1D0*FLTI
33755 65 CST=0.6D0+0.04D0*FLTI
33757 70 CST=0.78D0+0.02D0*FLTI
33760 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33765 *$ CREATE DT_DHADRI.FOR
33768 *===dhadri=============================================================*
33770 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33772 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33775 PARAMETER ( LINP = 10 ,
33779 C-----------------------------
33780 C*** INPUT VARIABLES LIST:
33781 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33782 C*** GEV/C LABORATORY MOMENTUM REGION
33783 C*** N - PROJECTILE HADRON INDEX
33784 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33785 C*** ELAB - LABORATORY ENERGY OF N (GEV)
33786 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33787 C*** ITTA - TARGET NUCLEON INDEX
33788 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33789 C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33790 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33791 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33792 C*** RESPECT., UNITS (GEV/C AND GEV)
33793 C----------------------------
33795 COMMON /HNGAMR/ REDU,AMO,AMM(15)
33796 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33797 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33798 & NRK(2,268),NURE(30,2)
33799 * particle properties (BAMJET index convention),
33800 * (dublicate of DTPART for HADRIN)
33801 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33802 & K1H(110),K2H(110)
33803 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33804 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33806 COMMON /HNDRUN/ RUNTES,EFTES
33807 * particle properties (BAMJET index convention)
33809 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33810 & IICH(210),IIBAR(210),K1(210),K2(210)
33811 * final state from HADRIN interaction
33812 PARAMETER (MAXFIN=10)
33813 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33814 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33816 DIMENSION ITPRF(110)
33819 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33821 IF (N.LE.0.OR.N.GE.111)N=1
33822 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33825 * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33827 *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33828 * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33831 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
33832 C IF(IPRI.GE.1) WRITE (6,1010) PLAB
33834 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33835 + ALLOWED REGION, PLAB=',1E15.5)
33838 UMODAT=N*1.11111D0+ITTA*2.19291D0
33839 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33846 IF (LOWP.GT.20) THEN
33847 C WRITE(LOUT,*) ' jump 1'
33851 IF (NNN.EQ.N) GO TO 50
33860 IF(ITTA.GT.1) IRE=NURE(N,2)
33862 C-----------------------------
33863 C*** IE,AMT,ECM,SI DETERMINATION
33864 C----------------------------
33865 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33868 C IF (AMH(1).NE.0.93828D0) IANTH=1
33869 IF (AMH(1).NE.0.9383D0) IANTH=1
33871 IF (IANTH.GE.0) SI=1.0D0
33874 C-----------------------------
33876 C IRE CHARACTERIZES THE REACTION
33877 C IE IS THE ENERGY INDEX
33878 C----------------------------
33879 IF (SI.LT.1.D-6) THEN
33880 C WRITE(LOUT,*) ' jump 2'
33883 IF (N.LE.NSTAB) GO TO 60
33884 RUNTES=RUNTES+1.0D0
33885 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33886 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33887 IF(IBARH(N).EQ.1) N=8
33888 IF(IBARH(N).EQ.-1) N=9
33891 **sr 19.2.97: loop for direct channel suppression
33892 C IF (IMACH.GT.10) THEN
33893 IF (IMACH.GT.1000) THEN
33895 C WRITE(LOUT,*) ' jump 3'
33901 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
33902 IF(ECMN.LE.AMN) ECMN=AMN
33903 PCMN=SQRT(ECMN**2-AMN2)
33906 IF (IANTH.GE.0) ECM=2.1D0
33908 C-----------------------------
33909 C*** RANDOM CHOICE OF REACTION CHANNEL
33910 C----------------------------
33915 C-----------------------------
33916 C*** PLACE REDUCED VERSION
33917 C----------------------------
33919 IDWK=IEII(IRE+1)-IIEI
33923 C-----------------------------
33924 C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33925 C----------------------------
33927 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33928 IF (HUMO.LT.ECM) ECM=HUMO
33930 C-----------------------------
33931 C*** INTERPOLATION PREPARATION
33932 C----------------------------
33938 C-----------------------------
33940 C----------------------------
33945 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33949 C-----------------------------
33950 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
33951 C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
33953 C----------------------------
33954 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
33955 WICO=WOK*1.23459876D0+WDK*1.735218469D0
33956 IF (WICO.EQ.WICOR) GO TO 70
33957 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
33960 C-----------------------------
33961 C*** INTERPOLATION IN CHANNEL WEIGHTS
33962 C----------------------------
33963 EKLIM=-THRESH(IIKI+IK)
33964 IELIM=IDT_IEFUND(EKLIM,IRE)
33965 DELIM=UMO(IELIM)+EKLIM
33967 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33968 IF (DELIM*DELIM-DETE*DETE) 90,90,80
33973 WKK=WOK-WDK*DEC/(DECC+1.D-9)
33975 C-----------------------------
33977 C----------------------------
33979 IF (VV.GT.WKK) GO TO 70
33981 C***IK IS THE REACTION CHANNEL
33982 C----------------------------
33994 IF (I1001.GT.50) GO TO 60
33996 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
33999 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34002 IF (IT2.GT.0) GO TO 120
34003 **sr 19.2.97: supress direct channel for pp-collisions
34004 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34006 IF (RR.LE.0.75D0) GOTO 60
34010 C-----------------------------
34011 C INCLUSION OF DIRECT RESONANCES
34012 C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
34013 C------------------------
34026 IF(WW.LT. 0.5D0) GO TO 130
34033 C-----------------------------
34034 C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34041 IF(IB1.EQ.IBN) GO TO 140
34047 C-----------------------------
34048 C***IT1,IT2 ARE THE CREATED PARTICLES
34049 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34050 C------------------------
34051 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34052 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34057 C-----------------------------
34058 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34059 C----------------------------
34060 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34061 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34065 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34066 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34069 C-----------------------------
34070 C***TEST STABLE OR UNSTABLE
34071 C----------------------------
34072 IF(ITS(IST).GT.NSTAB) GO TO 160
34075 C-----------------------------
34076 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34077 C----------------------------
34078 C* IF (REDU.LT.0.D0) GO TO 1009
34086 IF(IST.GE.1) GO TO 150
34090 C RANDOM CHOICE OF DECAY CHANNELS
34091 C----------------------------
34105 IF (VV.GT.WTI(IIK)) GO TO 180
34107 C IIK IS THE DECAY CHANNEL
34108 C----------------------------
34116 IF (IT2-1.LT.0) GO TO 240
34121 C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34122 C----------------------------
34123 IF (IECO.LE.10) GO TO 200
34125 IF(IATMPT.GT.3) THEN
34126 C WRITE(LOUT,*) ' jump 4'
34131 IF (I310.GT.50) GO TO 170
34132 IF (AMS.GT.ECO) GO TO 190
34134 C FOR THE DECAY CHANNEL
34135 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
34136 C----------------------------
34137 IF (REDU.LT.0.D0) GO TO 30
34140 IF(IT3.EQ.0) GO TO 220
34143 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34144 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34146 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34147 &COD2,COF2,SIF2,AM1,AM2)
34152 IF (REDU.GT.0.D0) GO TO 240
34154 IF (ITWTHC.GT.100) GO TO 30
34155 IF (ITWTH) 220,220,210
34158 IF (IT2-1.LT.0) GO TO 250
34165 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34166 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34169 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34170 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34171 IF (IT3.LE.0) GO TO 250
34174 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34175 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34183 C----------------------------
34185 C ZERO CROSS SECTION CASE
34186 C----------------------------
34198 *$ CREATE DT_RUNTT.FOR
34201 *===runtt==============================================================*
34203 BLOCK DATA DT_RUNTT
34205 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34208 COMMON /HNDRUN/ RUNTES,EFTES
34210 DATA RUNTES,EFTES /100.D0,100.D0/
34214 *$ CREATE DT_NONAME.FOR
34217 *===noname=============================================================*
34219 BLOCK DATA DT_NONAME
34221 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34224 * slope parameters for HADRIN interactions
34225 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34226 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34228 C DATAS DATAS DATAS DATAS DATAS
34230 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34231 & 207, 224, 241, 252, 268 /
34232 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34233 & 220, 241, 262, 279, 296 /
34234 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34235 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
34238 C MASSES FOR THE SLOPE B(M) IN GEV
34239 C SLOPE B(M) FOR AN MESONIC SYSTEM
34240 C SLOPE B(M) FOR A BARYONIC SYSTEM
34243 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
34244 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
34245 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
34246 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
34247 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
34248 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34249 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
34250 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
34251 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
34252 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
34253 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
34254 & 14.2D0, 13.4D0, 12.6D0,
34255 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
34256 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
34260 *$ CREATE DT_DAMG.FOR
34263 *===damg===============================================================*
34265 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34267 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34270 * particle properties (BAMJET index convention),
34271 * (dublicate of DTPART for HADRIN)
34272 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34273 & K1H(110),K2H(110)
34275 DIMENSION GASUNI(14)
34277 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34278 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34279 DATA GAUNO/2.352D0/
34285 IF (IT.LE.0) GO TO 30
34286 IF (IT.LE.NSTAB) GO TO 20
34287 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34289 VV=VV*2.0D0-1.0D0+1.D-16
34294 IF (VV.GT.V1) GO TO 10
34295 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34296 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34297 DAM=GAH(IT)*UNIGA/GAUNO
34309 *$ CREATE DT_DCALUM.FOR
34312 *===dcalum=============================================================*
34314 SUBROUTINE DT_DCALUM(N,ITTA)
34316 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34319 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34321 * particle properties (BAMJET index convention),
34322 * (dublicate of DTPART for HADRIN)
34323 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34324 & K1H(110),K2H(110)
34325 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34326 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34327 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34328 & NRK(2,268),NURE(30,2)
34330 IRE=NURE(N,ITTA/8+1)
34339 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34346 IF(NRK(2,IK).GT.0) GO TO 30
34355 IF(IN.GT.0)AMS=AMS+AMH(IN)
34357 IF(IN.GT.0) AMS=AMS+AMH(IN)
34358 IF (AMS.LT.AMSS) AMSS=AMS
34360 IF(UMOO.LT.AMSS) UMOO=AMSS
34366 *$ CREATE DT_DCHANH.FOR
34369 *===dchanh=============================================================*
34371 SUBROUTINE DT_DCHANH
34373 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34376 PARAMETER ( LINP = 10 ,
34379 * particle properties (BAMJET index convention),
34380 * (dublicate of DTPART for HADRIN)
34381 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34382 & K1H(110),K2H(110)
34383 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34384 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34385 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34386 & NRK(2,268),NURE(30,2)
34388 DIMENSION HWT(460),HWK(40),SI(5184)
34389 EQUIVALENCE (WK(1),SI(1))
34390 C--------------------
34391 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34392 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34393 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34394 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34395 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34396 C--------------------------
34400 IEE=IEII(IRE+1)-IEII(IRE)
34401 IKE=IKII(IRE+1)-IKII(IRE)
34404 * modifications to suppress elestic scattering 24/07/91
34409 IWK=IWKO+IEE*(IK-1)+IE
34410 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34411 SIS=SIS+SI(IWK)*SINORC
34415 IF (SIS.GE.1.D-12) GO TO 20
34421 IWK=IWKO+IEE*(IK-1)+IE
34422 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34423 SIO=SIO+SI(IWK)*SINORC/SIS
34427 IWK=IWKO+IEE*(IK-1)+IE
34432 INRK1=NRK(1,IIKI+IK)
34433 IF (INRK1.GT.0) AM111=AMH(INRK1)
34435 INRK2=NRK(2,IIKI+IK)
34436 IF (INRK2.GT.0) AM222=AMH(INRK2)
34437 THRESH(IIKI+IK)=AM111 +AM222
34438 IF (INRK2-1.GE.0) GO TO 60
34442 DO 50 INRK1=INRKK,INRKO
34443 INZK1=NZKI(INRK1,1)
34444 INZK2=NZKI(INRK1,2)
34445 INZK3=NZKI(INRK1,3)
34446 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
34447 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
34448 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
34449 C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34451 AMS=AMH(INZK1)+AMH(INZK2)
34452 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34453 IF (AMSS.GT.AMS) AMSS=AMS
34456 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34457 THRESH(IIKI+IK)=AMS
34468 IF (IK2.GT.460)IK2=460
34475 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34476 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34483 *$ CREATE DT_DHADDE.FOR
34486 *===dhadde=============================================================*
34488 SUBROUTINE DT_DHADDE
34490 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34493 * particle properties (BAMJET index convention)
34495 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34496 & IICH(210),IIBAR(210),K1(210),K2(210)
34497 * HADRIN: decay channel information
34498 PARAMETER (IDMAX9=602)
34500 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34501 * particle properties (BAMJET index convention),
34502 * (dublicate of DTPART for HADRIN)
34503 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34504 & K1H(110),K2H(110)
34505 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34506 * decay channel information for HADRIN
34507 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34508 & K1Z(16),K2Z(16),WTZ(153),II22,
34509 & NZK1(153),NZK2(153),NZK3(153)
34515 IF (IRETUR.GT.1) RETURN
34521 IBARH(I) = IIBAR(I)
34536 NZKI(I,1) = NZK(I,1)
34537 NZKI(I,2) = NZK(I,2)
34538 NZKI(I,3) = NZK(I,3)
34553 NZKI(L,3) = NZK3(I)
34554 NZKI(L,2) = NZK2(I)
34555 NZKI(L,1) = NZK1(I)
34560 *$ CREATE IDT_IEFUND.FOR
34563 *===iefund=============================================================*
34565 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34567 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34570 C*****IEFUN CALCULATES A MOMENTUM INDEX
34572 PARAMETER ( LINP = 10 ,
34575 COMMON /HNDRUN/ RUNTES,EFTES
34576 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34577 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34578 & NRK(2,268),NURE(30,2)
34583 IF (PL.LT.0.) GO TO 30
34586 IF (PL.LE.PLABF(I)) GO TO 60
34589 IF ( EFTES.GT.40.D0) GO TO 20
34591 WRITE(LOUT,1000)PL,J
34597 IF (-PL.LE.UMO(I)) GO TO 60
34600 IF ( EFTES.GT.40.D0) GO TO 50
34602 WRITE(LOUT,1000)PL,I
34608 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34612 *$ CREATE DT_DSIGIN.FOR
34615 *===dsigin=============================================================*
34617 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34619 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34622 * particle properties (BAMJET index convention),
34623 * (dublicate of DTPART for HADRIN)
34624 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34625 & K1H(110),K2H(110)
34626 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34627 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34628 & NRK(2,268),NURE(30,2)
34630 IE=IDT_IEFUND(PLAB,IRE)
34631 IF (IE.LE.IEII(IRE)) IE=IE+1
34636 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34637 C*** INTERPOLATION PREPARATION
34643 EKLIM=-THRESH(IIKI)
34646 IF (ECM.GT.ECMO) WDK=0.0D0
34647 C*** INTERPOLATION IN CHANNEL WEIGHTS
34648 IELIM=IDT_IEFUND(EKLIM,IRE)
34649 DELIM=UMO(IELIM)+EKLIM
34651 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34652 IF (DELIM*DELIM-DETE*DETE) 20,20,10
34657 WKK=WOK-WDK*DEC/(DECC+1.D-9)
34658 IF (WKK.LT.0.0D0) WKK=0.0D0
34660 IF (-EKLIM.GT.ECM) SI=1.D-14
34664 *$ CREATE DT_DTCHOI.FOR
34667 *===dtchoi=============================================================*
34669 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34671 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34674 C ****************************
34675 C TCHOIC CALCULATES A RANDOM VALUE
34676 C FOR THE FOUR-MOMENTUM-TRANSFER T
34677 C ****************************
34679 * particle properties (BAMJET index convention),
34680 * (dublicate of DTPART for HADRIN)
34681 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34682 & K1H(110),K2H(110)
34683 * slope parameters for HADRIN interactions
34684 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34688 IF (I.GT.30.AND.II.GT.30) GO TO 20
34691 IF (I.LE.30) GO TO 10
34699 IF (AMA.LE.AMB) GO TO 30
34705 K=INT((AMA-0.75D0)/0.05D0)
34707 IF (K-26.GE.0) K=25
34714 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
34715 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
34718 C IF (VB.LT.0.2D0) BM=BM*0.1
34725 IF (ABS(TMA).GT.120.D0) GO TO 70
34728 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34729 C*** RANDOM CHOICE OF THE T - VALUE
34731 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34735 *$ CREATE DT_DTWOPA.FOR
34738 *===dtwopa=============================================================*
34740 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34741 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34743 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34746 C ******************************************************
34747 C QUASI TWO PARTICLE PRODUCTION
34748 C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34749 C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34750 C IN THE CM - SYSTEM
34751 C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34752 C SPHERICAL COORDINATES
34753 C ******************************************************
34755 * particle properties (BAMJET index convention),
34756 * (dublicate of DTPART for HADRIN)
34757 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34758 & K1H(110),K2H(110)
34763 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34765 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34766 AMTE=(E1-AMA)*(E1+AMA)
34770 C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
34771 C DETERMINATION OF THE ANGLES
34772 C COS(THETA1)=COD1 COS(THETA2)=COD2
34773 C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
34774 C COS(PHI1)=COF1 COS(PHI2)=COF2
34775 C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34776 CALL DT_DSFECF(COF1,SIF1)
34779 C CALCULATION OF THETA1
34780 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34781 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34782 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34787 *$ CREATE DT_ZK.FOR
34790 *===zk=================================================================*
34794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34797 * decay channel information for HADRIN
34798 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34799 & K1Z(16),K2Z(16),WTZ(153),II22,
34800 & NZK1(153),NZK2(153),NZK3(153)
34801 * decay channel information for HADRIN
34802 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34803 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34805 * Particle masses in GeV *
34806 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34808 * Resonance width Gamma in GeV *
34809 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34810 * Mean life time in seconds *
34811 DATA TAUZ / 16*0.D0 /
34812 * Charge of particles and resonances *
34813 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34814 * Baryonic charge *
34815 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34816 * First number of decay channels used for resonances *
34817 * and decaying particles *
34818 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34820 * Last number of decay channels used for resonances *
34821 * and decaying particles *
34822 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34824 * Weight of decay channel *
34825 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34826 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34827 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34828 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34829 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34830 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34831 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34832 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34833 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34834 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34835 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34836 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34837 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34838 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34839 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34840 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34841 & .05D0, .65D0, 9*1.D0 /
34842 * Particle numbers in decay channel *
34843 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34844 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34845 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34846 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34847 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34848 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34849 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34850 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34851 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34852 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34853 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34854 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34855 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34856 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34857 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34858 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34859 & 1, 8, 1, 8, 1, 9*0 /
34860 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34861 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34862 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34863 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34864 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34865 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34867 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
34868 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34870 * Name of decay channel *
34871 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34872 & 'ANNPI0','APPPI0','ANPPI-'/
34873 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
34874 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
34875 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
34876 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34877 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34878 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34879 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34881 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
34882 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34883 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34884 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34885 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
34886 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34887 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34888 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34889 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
34890 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34891 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34892 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34893 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34898 *$ CREATE DT_BLKD43.FOR
34901 *===blkd43=============================================================*
34903 BLOCK DATA DT_BLKD43
34905 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34909 *=== reac =============================================================*
34911 *----------------------------------------------------------------------*
34913 * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
34916 * Last change on 10-dec-91 by Alfredo Ferrari *
34918 * This is the original common reac of Hadrin *
34920 *----------------------------------------------------------------------*
34922 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34923 & NRK(2,268),NURE(30,2)
34926 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34927 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34928 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34929 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34930 & SPIKP5(187), SPIKP6(289),
34931 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34932 & SPIKP9(143), SPIKP0(169), SPKPV(143),
34933 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34934 & SANPEL(84) , SPIKPF(273),
34935 & SPKP15(187), SPKP16(272),
34936 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34939 DIMENSION NRKLIN(532)
34940 EQUIVALENCE (NRK(1,1), NRKLIN(1))
34941 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
34942 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
34943 EQUIVALENCE ( UMO(263), UMOK0(1))
34944 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
34945 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
34946 EQUIVALENCE ( PLABF(263), PLAK0(1))
34947 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
34948 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
34949 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
34950 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
34951 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
34952 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
34953 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
34954 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
34955 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
34956 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
34957 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
34958 EQUIVALENCE ( WK(4913), SPKP16(1))
34959 EQUIVALENCE (NRK(1,1), NRKLIN(1))
34960 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
34961 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
34962 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
34963 EQUIVALENCE (NURE(1,1), NURELN(1))
34967 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
34968 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
34969 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
34970 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
34971 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
34972 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
34973 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
34974 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
34975 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
34976 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
34978 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34979 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34980 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34981 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34982 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34983 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34984 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34985 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34986 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34987 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34988 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34989 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
34991 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34992 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34993 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34994 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34995 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34996 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
34999 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35000 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35001 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35002 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35003 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35004 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35005 * app apn anp ann *
35007 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35008 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35009 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35010 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35011 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35012 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35013 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35014 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35015 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35016 DATA SIIN / 296*0.D0 /
35017 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35018 & 1.557D0,1.615D0,1.6435D0,
35019 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35020 & 2.286D0,2.366D0,2.482D0,2.56D0,
35022 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35023 & 1.496D0,1.527D0,1.557D0,
35024 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35025 & 2.071D0,2.159D0,2.286D0,2.366D0,
35026 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35027 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35028 & 1.496D0,1.527D0,1.557D0,
35029 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35030 & 2.071D0,2.159D0,2.286D0,2.366D0,
35031 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35032 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35033 & 1.557D0,1.615D0,1.6435D0,
35034 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35035 & 2.286D0,2.366D0,2.482D0,2.56D0,
35037 DATA UMOKC/ 1.44D0,
35038 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35039 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35041 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35042 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35044 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35045 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35047 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35048 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35050 DATA UMOK0/ 1.44D0,
35051 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35052 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35054 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35055 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35059 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35060 & 3.D0,3.1D0,3.2D0,
35061 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35062 & 3.D0,3.1D0,3.2D0,
35063 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35064 & 3.D0,3.1D0,3.2D0/
35065 * app apn anp ann *
35067 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35068 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35069 & 3.D0,3.1D0,3.2D0,
35070 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35071 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35072 & 3.D0,3.1D0,3.2D0,
35073 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35074 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35075 & 3.D0,3.1D0,3.2D0/
35076 **** reaction channel state particles *
35077 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35078 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35079 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35080 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35081 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35082 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35083 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35084 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35085 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35086 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35087 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35088 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35089 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35090 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35091 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35092 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35093 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35094 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35096 * k0 p k0 n ak0 p ak/ n *
35098 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35099 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
35100 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35101 & 53, 47, 1, 103, 0, 93, 0/
35103 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35104 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35105 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35106 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35107 * app apn anp ann *
35108 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35109 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35110 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35111 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35112 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35113 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35114 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35115 **** channel cross section *
35116 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35117 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35118 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35119 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35120 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35121 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35122 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35123 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35124 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35125 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35126 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35127 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35128 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35129 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35130 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35131 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35132 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35133 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35134 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35135 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35137 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
35138 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35139 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35140 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35141 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
35142 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
35143 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
35144 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
35145 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
35146 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
35147 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
35148 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
35149 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
35150 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
35151 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35152 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
35153 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
35154 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
35155 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
35156 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35158 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35159 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35160 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35161 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35162 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35163 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35164 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35165 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35166 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35167 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35168 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35169 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35170 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35171 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35172 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35173 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35174 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35175 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35176 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35177 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35179 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35180 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35181 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35182 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35183 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35184 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35185 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35186 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35187 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35188 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35189 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35190 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35191 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35192 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35193 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35194 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35195 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35196 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35197 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35199 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35200 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35201 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35202 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35203 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35204 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35205 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35206 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35207 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35208 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35209 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35210 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35211 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35212 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35213 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35214 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35215 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35216 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35217 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35218 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35220 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35221 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35222 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35223 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35224 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35225 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35226 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35227 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35228 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35229 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35230 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35231 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35232 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35233 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35234 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35235 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35236 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35237 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35238 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35239 & 3.3D0, 5.4D0, 7.D0 /
35241 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35242 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35243 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35244 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35245 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35246 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35247 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35248 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35249 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35250 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35251 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35252 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35253 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35255 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35256 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35257 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35258 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35259 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35260 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35261 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35262 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35263 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35264 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35265 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35266 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35267 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35268 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35269 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35270 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35271 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35272 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35273 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35275 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35276 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35277 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35278 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35279 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35280 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35281 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35282 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35283 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35284 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35285 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35286 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35287 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35288 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35289 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35290 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35291 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
35292 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35293 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35294 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35295 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35296 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35297 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35298 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35299 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35300 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35301 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35302 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35303 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35304 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35305 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35306 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35309 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35310 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35311 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35312 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35313 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35314 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35315 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35316 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35317 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35318 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35319 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35320 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35321 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35322 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35323 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35324 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35325 & .39D0, .22D0, .07D0, 0.D0,
35326 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35327 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35328 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35329 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35330 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35331 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35332 & 5.10D0, 5.44D0, 5.3D0,
35333 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35335 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35336 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35337 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
35338 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35339 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35340 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35341 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35342 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35343 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35344 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35345 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35346 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35347 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35348 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35349 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35351 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35352 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35353 & 0.D0, 1.8D0, .2D0, 12*0.D0,
35354 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35355 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35356 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35357 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35358 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35359 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35360 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35361 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35362 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35363 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35364 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35365 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35366 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35367 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35368 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35371 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35372 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35373 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
35374 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35375 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35376 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35377 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35378 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35379 & 11.D0, 5.5D0, 3.5D0,
35380 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35381 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35382 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35383 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35384 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35385 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35386 **************** ap - p - data *
35387 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35388 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35389 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35390 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35391 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35392 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35393 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35394 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35395 & 1.55D0, 1.3D0, .95D0, .75D0,
35396 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35397 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35398 & .01D0, .008D0, .006D0, .005D0/
35399 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35400 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35401 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35402 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35403 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35404 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35405 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35406 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35407 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35408 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35409 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35410 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35411 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35412 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35413 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35414 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35415 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35416 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35417 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35418 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35419 **************** ap - n - data *
35421 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35422 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35423 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35424 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
35425 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
35426 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35427 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35428 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35429 & .01D0, .008D0, .006D0, .005D0 /
35430 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35431 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35432 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35433 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35434 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35435 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35436 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35437 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35438 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35439 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35440 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35441 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35442 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35443 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35446 **************** an - p - data *
35449 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35450 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35451 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
35452 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35453 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35454 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35455 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35456 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35457 & .01D0, .008D0, .006D0, .005D0 /
35458 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35459 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35460 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35461 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35462 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35463 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35464 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35465 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35466 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35467 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35468 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35469 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35470 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35471 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35472 **** ko - n - data *
35473 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35474 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35475 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35476 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35477 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35478 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35479 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35480 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35481 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
35482 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35483 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35485 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35486 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35487 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
35488 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35489 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
35490 **** ako - p - data *
35491 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35492 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35493 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35494 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35495 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35496 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35497 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35498 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35499 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35500 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35501 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35502 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35503 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35504 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35505 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35506 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35507 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35508 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35509 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35510 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35511 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35512 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35513 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35514 *= end*block.blkdt3 *
35517 *$ CREATE DT_QEL_POL.FOR
35520 *===qel_pol============================================================*
35522 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35524 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35528 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35533 *$ CREATE DT_GEN_QEL.FOR
35535 C==================================================================
35536 C Generation of a Quasi-Elastic neutrino scattering
35537 C==================================================================
35539 *===gen_qel============================================================*
35541 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35543 C...Generate a quasi-elastic neutrino/antineutrino
35544 C. Interaction on a nuclear target
35545 C. INPUT : LTYP = neutrino type (1,...,6)
35546 C. ENU (GeV) = neutrino energy
35547 C----------------------------------------------------
35549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35552 PARAMETER ( LINP = 10 ,
35555 PARAMETER (MAXLND=4000)
35556 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35557 * nuclear potential
35559 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35560 & EBINDP(2),EBINDN(2),EPOT(2,210),
35561 & ETACOU(2),ICOUL,LFERMI
35562 * steering flags for qel neutrino scattering modules
35563 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35564 **sr - removed (not needed)
35565 C COMMON /CBAD/ LBAD, NBAD
35566 C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35569 DIMENSION PI(3),PO(3)
35574 C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35575 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35576 DATA AMN /0.93827231D0, 0.93956563D0/
35577 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35580 C DATA PFERMI/0.22D0/
35581 CGB+...Binding Energy
35582 DATA EBIND/0.008D0/
35586 IF(ININU.EQ.1)NDSIG=0
35591 AML = AML0(LTYP) ! massa leptoni
35592 AML2 = AML**2 ! massa leptoni **2
35593 C...Particle labels (LUND)
35603 K0 = (LTYP-1)/2 ! 2
35605 KA = 12 + 2*K0 ! 16
35606 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
35610 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
35611 IF (LNU .EQ. 2) THEN
35639 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
35640 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35645 C...4-momentum initial lepton
35646 P(1,5) = 0. ! massa
35647 P(1,4) = ENU0 ! energia
35652 C PF = PFERMI*PYR(0)**(1./3.)
35653 c write(23,*) PYR(0)
35654 c write(*,*) 'Pfermi=',PF
35657 C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35658 IF (NTRY .GT. 500) THEN
35660 WRITE (LOUT,1001) NBAD, ENU
35663 C CT = -1. + 2.*PYR(0)
35665 C ST = SQRT(1.-CT*CT)
35666 C F = 2.*3.1415926*PYR(0)
35669 C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
35670 C P(2,1) = PF*ST*COS(F) ! px
35671 C P(2,2) = PF*ST*SIN(F) ! py
35672 C P(2,3) = PF*CT ! pz
35673 C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
35679 beta1=-p(2,1)/p(2,4)
35680 beta2=-p(2,2)/p(2,4)
35681 beta3=-p(2,3)/p(2,4)
35683 C WRITE(6,*)' before transforming into target rest frame'
35684 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35685 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35688 phi11=atan(p(1,2)/p(1,3))
35693 CALL DT_TESTROT(PI,Po,PHI11,1)
35695 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35701 phi12=atan(p(1,1)/p(1,3))
35706 CALL DT_TESTROT(Pi,Po,PHI12,2)
35708 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35717 C...Kinematical limits in Q**2
35718 c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
35719 S = P(2,5)**2 + 2.*ENU*P(2,5)
35720 SQS = SQRT(S) ! E centro massa
35721 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35722 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
35723 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
35724 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
35725 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
35726 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
35727 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
35730 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35731 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35732 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35733 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35734 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35736 C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35737 C &Q2,Q2min,Q2MAX,DSIGEV
35739 C...c.m. frame. Neutrino along z axis
35740 DETOT = (P(1,4)) + (P(2,4)) ! e totale
35741 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35742 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35743 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35746 C WRITE(*,*) 'Input values laboratory frame'
35749 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35752 c STHETA = ULANGL(P(1,3),P(1,1))
35753 c write(*,*) 'stheta' ,stheta
35755 c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35758 C WRITE(*,*) 'Output values cm frame'
35759 C...Kinematic in c.m. frame
35760 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35761 STSTAR = SQRT(1.-CTSTAR**2)
35762 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35763 P(4,5) = AML ! massa leptone
35764 P(4,4) = ELF ! e leptone
35765 P(4,3) = PLF*CTSTAR ! px
35766 P(4,1) = PLF*STSTAR*COS(PHI) ! py
35767 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35769 P(5,5) = AMF ! barione
35770 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35771 P(5,3) = -P(4,3) ! px
35772 P(5,1) = -P(4,1) ! py
35773 P(5,2) = -P(4,2) ! pz
35776 P(3,1) = P(1,1)-P(4,1)
35777 P(3,2) = P(1,2)-P(4,2)
35778 P(3,3) = P(1,3)-P(4,3)
35779 P(3,4) = P(1,4)-P(4,4)
35781 C...Transform back to laboratory frame
35782 C WRITE(*,*) 'before going back to nucl rest frame'
35783 c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35786 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35788 C WRITE(*,*) 'Now back in nucl rest frame'
35789 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35791 c********************************************
35797 CALL DT_TESTROT(Pi,Po,PHI12,3)
35799 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35805 c********************************************
35811 CALL DT_TESTROT(Pi,Po,PHI11,4)
35813 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35820 c********************************************
35822 C WRITE(*,*) 'Now back in lab frame'
35824 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35827 C...test (on final momentum of nucleon) if Fermi-blocking
35829 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35831 IF (ENUCL.LT. EFMAX) THEN
35832 IF(INIPRI.LT.10)THEN
35834 C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35835 C...the interaction is not possible due to Pauli-Blocking and
35836 C...it must be resampled
35839 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35840 IF(INIPRI.LT.10)THEN
35842 C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35844 C Reject (J:R) here all these events
35845 C are otherwise rejected in dpmjet
35847 C...the interaction is possible, but the nucleon remains inside
35848 C...the nucleus. The nucleus is therefore left excited.
35849 C...We treat this case as a nucleon with 0 kinetic energy.
35855 ELSE IF (ENUCL.GE.ENWELL) THEN
35856 C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35857 C...the interaction is possible, the nucleon can exit the nucleus
35858 C...but the nuclear well depth must be subtracted. The nucleus could be
35859 C...left in an excited state.
35860 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35861 C P(5,4) = ENUCL-ENWELL + AMF
35862 Pnucl = SQRT(P(5,4)**2-AMF**2)
35863 C...The 3-momentum is scaled assuming that the direction remains
35865 P(5,1) = P(5,1) * Pnucl/Pstart
35866 P(5,2) = P(5,2) * Pnucl/Pstart
35867 P(5,3) = P(5,3) * Pnucl/Pstart
35868 C WRITE(6,*)' qel new P(5,4) ',P(5,4)
35871 DSIGSU=DSIGSU+DSIGEV
35881 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35883 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35887 C PRINT*,' FINE EVENTO '
35891 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
35894 *$ CREATE DT_MASS_INI.FOR
35896 C====================================================================
35898 C====================================================================
35900 *===mass_ini===========================================================*
35902 SUBROUTINE DT_MASS_INI
35903 C...Initialize the kinematics for the quasi-elastic cross section
35905 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35908 * particle masses used in qel neutrino scattering modules
35909 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35910 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35911 & EMPROTSQ,EMNEUTSQ,EMNSQ
35913 EML(1) = 0.51100D-03 ! e-
35914 EML(2) = EML(1) ! e+
35915 EML(3) = 0.105659D0 ! mu-
35916 EML(4) = EML(3) ! mu+
35917 EML(5) = 1.7777D0 ! tau-
35918 EML(6) = EML(5) ! tau+
35919 EMPROT = 0.93827231D0 ! p
35920 EMNEUT = 0.93956563D0 ! n
35921 EMPROTSQ = EMPROT**2
35922 EMNEUTSQ = EMNEUT**2
35923 EMN = (EMPROT + EMNEUT)/2.
35927 EMN1(J0+1) = EMNEUT
35928 EMN1(J0+2) = EMPROT
35929 EMN2(J0+1) = EMPROT
35930 EMN2(J0+2) = EMNEUT
35933 EMLSQ(J) = EML(J)**2
35934 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35939 *$ CREATE DT_DSQEL_Q2.FOR
35942 *===dsqel_q2===========================================================*
35944 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35946 C...differential cross section for Quasi-Elastic scattering
35947 C. nu + N -> l + N'
35948 C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
35950 C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
35951 C. ENU (GeV) = Neutrino energy
35952 C. Q2 (GeV**2) = (Transfer momentum)**2
35954 C. OUTPUT : DSQEL_Q2 = differential cross section :
35955 C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
35956 C------------------------------------------------------------------
35958 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35961 * particle masses used in qel neutrino scattering modules
35962 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35963 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35964 & EMPROTSQ,EMNEUTSQ,EMNSQ
35965 **sr - removed (not needed)
35966 C COMMON /CAXIAL/ FA0, AXIAL2
35970 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
35971 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
35972 DATA AXIAL2 /1.03D0/ ! to be checked
35976 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
35977 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
35978 X = Q2/(EMN*EMN) ! emn=massa barione
35980 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
35981 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
35982 FA = FA0/(1.D0 + Q2/AXIAL2)**2
35986 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
35987 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
35988 A2 = -RM * ((FV1 + FV2)**2 + FFA)
35989 AA = (XA+0.25D0*RM)*(A1 + A2)
35990 BB = -X*FA*(FV1 + FV2)
35991 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
35992 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
35993 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
35994 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
35999 *$ CREATE DT_PREPOLA.FOR
36002 *===prepola============================================================*
36004 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36006 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36009 c By G. Battistoni and E. Scapparone (sept. 1997)
36011 c Albright & Jarlskog, Nucl Phys B84 (1975) 467
36014 PARAMETER (MAXLND=4000)
36015 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36016 COMMON /QNPOL/ POLARX(4),PMODUL
36017 * particle masses used in qel neutrino scattering modules
36018 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36019 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36020 & EMPROTSQ,EMNEUTSQ,EMNSQ
36021 * steering flags for qel neutrino scattering modules
36022 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36023 **sr - removed (not needed)
36024 C COMMON /CAXIAL/ FA0, AXIAL2
36025 C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36026 C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36028 REAL*8 POL(4,4),BB2(3)
36030 C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36031 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36032 **sr uncommented since common block CAXIAL is now commented
36033 DATA AXIAL2 /1.03D0/ ! to be checked
36043 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
36044 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
36045 X = Q2/(EMN*EMN) ! emn=massa barione
36047 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36048 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36049 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36053 FP=2.D0*FA*RMM/(MPI**2 + Q2)
36054 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
36055 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36056 A2 = -RM * ((FV1 + FV2)**2 + FFA)
36057 AA = (XA+0.25D+00*RM)*(A1 + A2)
36058 BB = -X*FA*(FV1 + FV2)
36059 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36060 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36062 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
36064 OMEGA3=2.D+00*FA*(FV1+FV2)
36065 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36068 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36069 WW1=2.D+00*OMEGA1*EMN**2
36070 WW2=2.D+00*OMEGA2*EMN**2
36071 WW3=2.D+00*OMEGA3*EMN**2
36072 WW4=2.D+00*OMEGA4*EMN**2
36073 WW5=2.D+00*OMEGA5*EMN**2
36076 BB2(I)=-P(4,I)/P(4,4)
36080 c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36082 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36083 * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
36086 c WRITE(*,*) 'Prepola: now in lepton rest frame'
36090 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36091 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36092 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36094 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36095 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
36097 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36100 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36106 PMODUL=PMODUL+POL(4,I)**2
36109 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36110 IF(NEUDEC.EQ.1) THEN
36111 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36113 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36115 c Tau has decayed in muon
36118 IF(NEUDEC.EQ.2) THEN
36119 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36121 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36123 c Tau has decayed in electron
36131 c fill common for muon(electron)
36139 IF(NEUDEC.EQ.1) THEN
36142 ELSEIF(NEUDEC.EQ.2) THEN
36146 ELSEIF(JTYP.EQ.6) THEN
36147 IF(NEUDEC.EQ.1) THEN
36149 ELSEIF(NEUDEC.EQ.2) THEN
36157 c fill common for tau_(anti)neutrino
36167 ELSEIF(JTYP.EQ.6) THEN
36174 c Fill common for muon(electron)_(anti)neutrino
36183 IF(NEUDEC.EQ.1) THEN
36185 ELSEIF(NEUDEC.EQ.2) THEN
36188 ELSEIF(JTYP.EQ.6) THEN
36189 IF(NEUDEC.EQ.1) THEN
36191 ELSEIF(NEUDEC.EQ.2) THEN
36202 c IF(PMODUL.GE.1.D+00) THEN
36203 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36204 c write(*,*) pmodul
36206 c POL(4,I)=POL(4,I)/PMODUL
36207 c POLARX(I)=POL(4,I)
36211 c PMODUL=PMODUL+POL(4,I)**2
36213 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36217 c WRITE(*,*) 'PMODUL = ',PMODUL
36221 c WRITE(*,*) 'prepola: Now back to nucl rest frame'
36222 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36224 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36225 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36226 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36236 *$ CREATE DT_TESTROT.FOR
36239 *===testrot============================================================*
36241 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36243 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36246 DIMENSION ROT(3,3),PI(3),PO(3)
36248 IF (MODE.EQ.1) THEN
36253 ROT(2,2) = COS(PHI)
36254 ROT(2,3) = -SIN(PHI)
36256 ROT(3,2) = SIN(PHI)
36257 ROT(3,3) = COS(PHI)
36258 ELSEIF (MODE.EQ.2) THEN
36262 ROT(2,1) = COS(PHI)
36264 ROT(2,3) = -SIN(PHI)
36265 ROT(3,1) = SIN(PHI)
36267 ROT(3,3) = COS(PHI)
36268 ELSEIF (MODE.EQ.3) THEN
36272 ROT(1,2) = COS(PHI)
36274 ROT(3,2) = -SIN(PHI)
36275 ROT(1,3) = SIN(PHI)
36277 ROT(3,3) = COS(PHI)
36278 ELSEIF (MODE.EQ.4) THEN
36283 ROT(2,2) = COS(PHI)
36284 ROT(3,2) = -SIN(PHI)
36286 ROT(2,3) = SIN(PHI)
36287 ROT(3,3) = COS(PHI)
36289 STOP ' TESTROT: mode not supported!'
36292 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36298 *$ CREATE DT_LEPDCYP.FOR
36301 *===lepdcyp============================================================*
36303 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36304 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36306 C-----------------------------------------------------------------
36308 C Author :- G. Battistoni 10-NOV-1995
36310 C=================================================================
36312 C Purpose : performs decay of polarized lepton in
36313 C its rest frame: a => b + l + anti-nu
36314 C (Example: mu- => nu-mu + e- + anti-nu-e)
36315 C Polarization is assumed along Z-axis
36317 C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36318 C OF NEGLIGIBLE MASS
36319 C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36322 C Method : modifies phase space distribution obtained
36323 C by routine EXPLOD using a rejection against the
36324 C matrix element for unpolarized lepton decay
36326 C Inputs : Mass of a : AMA
36329 C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36332 C Outputs : kinematic variables in the rest frame of decaying lepton
36333 C ETL,PXL,PYL,PZL 4-moment of l
36334 C ETB,PXB,PYB,PZB 4-moment of b
36335 C ETN,PXN,PYN,PZN 4-moment of anti-nu
36337 C============================================================
36341 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36344 PARAMETER ( LINP = 10 ,
36347 PARAMETER ( KALGNM = 2 )
36348 PARAMETER ( ANGLGB = 5.0D-16 )
36349 PARAMETER ( ANGLSQ = 2.5D-31 )
36350 PARAMETER ( AXCSSV = 0.2D+16 )
36351 PARAMETER ( ANDRFL = 1.0D-38 )
36352 PARAMETER ( AVRFLW = 1.0D+38 )
36353 PARAMETER ( AINFNT = 1.0D+30 )
36354 PARAMETER ( AZRZRZ = 1.0D-30 )
36355 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36356 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36357 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
36358 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
36359 PARAMETER ( CSNNRM = 2.0D-15 )
36360 PARAMETER ( DMXTRN = 1.0D+08 )
36361 PARAMETER ( ZERZER = 0.D+00 )
36362 PARAMETER ( ONEONE = 1.D+00 )
36363 PARAMETER ( TWOTWO = 2.D+00 )
36364 PARAMETER ( THRTHR = 3.D+00 )
36365 PARAMETER ( FOUFOU = 4.D+00 )
36366 PARAMETER ( FIVFIV = 5.D+00 )
36367 PARAMETER ( SIXSIX = 6.D+00 )
36368 PARAMETER ( SEVSEV = 7.D+00 )
36369 PARAMETER ( EIGEIG = 8.D+00 )
36370 PARAMETER ( ANINEN = 9.D+00 )
36371 PARAMETER ( TENTEN = 10.D+00 )
36372 PARAMETER ( HLFHLF = 0.5D+00 )
36373 PARAMETER ( ONETHI = ONEONE / THRTHR )
36374 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36375 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36376 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36377 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36378 PARAMETER ( CLIGHT = 2.99792458 D+10 )
36379 PARAMETER ( AVOGAD = 6.0221367 D+23 )
36380 PARAMETER ( AMELGR = 9.1093897 D-28 )
36381 PARAMETER ( PLCKBR = 1.05457266 D-27 )
36382 PARAMETER ( ELCCGS = 4.8032068 D-10 )
36383 PARAMETER ( ELCMKS = 1.60217733 D-19 )
36384 PARAMETER ( AMUGRM = 1.6605402 D-24 )
36385 PARAMETER ( AMMUMU = 0.113428913 D+00 )
36386 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36387 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36388 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36389 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36390 PARAMETER ( PLABRC = 0.197327053 D+00 )
36391 PARAMETER ( AMELCT = 0.51099906 D-03 )
36392 PARAMETER ( AMUGEV = 0.93149432 D+00 )
36393 PARAMETER ( AMMUON = 0.105658389 D+00 )
36394 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36395 PARAMETER ( GEVMEV = 1.0 D+03 )
36396 PARAMETER ( EMVGEV = 1.0 D-03 )
36397 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
36398 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36399 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36401 C variables for EXPLOD
36403 PARAMETER ( KPMX = 10 )
36404 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36405 & PZEXPL (KPMX), ETEXPL (KPMX)
36409 **sr - removed (not needed)
36410 C COMMON /GBATNU/ ELERAT,NTRY
36413 C Initializes test variables
36418 C Maximum value for matrix element
36420 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36421 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36422 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36423 C Inputs for EXPLOD
36424 C part. no. 1 is l (e- in mu- decay)
36425 C part. no. 2 is b (nu-mu in mu- decay)
36426 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36427 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36434 C phase space distribution
36439 CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36443 C Calculates matrix element:
36444 C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36445 C Here CTH is the cosine of the angle between anti-nu and Z axis
36447 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36449 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36450 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36451 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36452 ELEMAT = 16.D+00 * PROD1 * PROD2
36453 IF(ELEMAT.GT.ELEMAX) THEN
36454 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36458 C Here performs the rejection
36460 TEST = DT_RNDM(ETOTEX) * ELEMAX
36461 IF ( TEST .GT. ELEMAT ) GO TO 100
36463 C final assignment of variables
36465 ELERAT = ELEMAT/ELEMAX
36481 *$ CREATE DT_GEN_DELTA.FOR
36483 C==================================================================
36484 C. Generation of Delta resonance events
36485 C==================================================================
36487 *===gen_delta==========================================================*
36489 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36491 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36494 PARAMETER ( LINP = 10 ,
36497 C...Generate a Delta-production neutrino/antineutrino
36498 C. CC-interaction on a nucleon
36500 C. INPUT ENU (GeV) = Neutrino Energy
36501 C. LLEP = neutrino type
36502 C. LTARG = nucleon target type 1=p, 2=n.
36503 C. JINT = 1:CC, 2::NC
36505 C. OUTPUT PPL(4) 4-monentum of final lepton
36506 C----------------------------------------------------
36507 PARAMETER (MAXLND=4000)
36508 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36509 **sr - removed (not needed)
36510 C COMMON /CBAD/ LBAD, NBAD
36513 DIMENSION PI(3),PO(3)
36514 C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36515 DIMENSION AML0(6),AMN(2)
36516 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36517 DATA AMN /0.93827231, 0.93956563/
36518 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36520 c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36522 C...Final lepton mass
36523 IF (JINT.EQ.1) THEN
36530 C...Particle labels (LUND)
36538 IF (LTARG .EQ. 1) THEN
36546 IS = -1 + 2*LLEP - 4*K1
36547 LNU = 2 - LLEP + 2*K1
36551 IF (JINT .EQ. 1) THEN ! CC interactions
36555 IF (LTARG .EQ. 1) THEN
36561 IF (LTARG .EQ. 1) THEN
36568 K(3,2) = 23 ! NC (Z0) interactions
36570 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36571 * Delta0 for neutron (LTARG=2)
36572 C IF (LTARG .EQ. 1) THEN
36577 IF (LTARG .EQ. 1) THEN
36585 C...4-momentum initial lepton
36591 C...4-momentum initial nucleon
36592 P(2,5) = AMN(LTARG)
36603 beta1=-p(2,1)/p(2,4)
36604 beta2=-p(2,2)/p(2,4)
36605 beta3=-p(2,3)/p(2,4)
36608 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36610 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36612 phi11=atan(p(1,2)/p(1,3))
36617 CALL DT_TESTROT(PI,Po,PHI11,1)
36619 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36624 phi12=atan(p(1,1)/p(1,3))
36629 CALL DT_TESTROT(Pi,Po,PHI12,2)
36631 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36639 C...Generate the Mass of the Delta
36642 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36644 IF (NTRY .GT. 1000) THEN
36646 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36649 IF (AMD .LT. AMDMIN) GOTO 100
36650 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36651 IF (ENUU .LT. ET) GOTO 100
36653 C...Kinematical limits in Q**2
36654 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36656 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36657 ELF = (S - AMD**2 + AML2)/(2.*SQS)
36658 PLF = SQRT(ELF**2 - AML2)
36659 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36660 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36661 IF (Q2MIN .LT. 0.) Q2MIN = 0.
36663 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36664 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36665 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36666 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
36668 C...Generate the kinematics of the final particles
36669 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36670 GAM = EISTAR/AMN(LTARG)
36672 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36673 EL = GAM*(ELF + BET*PLF*CTSTAR)
36674 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36675 PL = SQRT(EL**2 - AML2)
36676 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36677 PHI = 6.28319*PYR(0)
36678 P(4,1) = PLT*COS(PHI)
36679 P(4,2) = PLT*SIN(PHI)
36684 C...4-momentum of Delta
36687 P(5,3) = ENUU-P(4,3)
36688 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36691 C...4-momentum of intermediate boson
36693 P(3,4) = P(1,4)-P(4,4)
36694 P(3,1) = P(1,1)-P(4,1)
36695 P(3,2) = P(1,2)-P(4,2)
36696 P(3,3) = P(1,3)-P(4,3)
36703 CALL DT_TESTROT(Pi,Po,PHI12,3)
36705 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36712 c********************************************
36718 CALL DT_TESTROT(Pi,Po,PHI11,4)
36720 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36726 c********************************************
36727 C transform back into Lab.
36729 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36731 C WRITE(6,*)' Lab fram ( fermi incl.) '
36736 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
36739 *$ CREATE DT_DSIGMA_DELTA.FOR
36740 *COPY DT_DSIGMA_DELTA
36742 *===dsigma_delta=======================================================*
36744 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36746 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36749 C...Reaction nu + N -> lepton + Delta
36750 C. returns the cross section
36752 C. INPUT LNU = 1, 2 (neutrino-antineutrino)
36753 C. QQ = t (always negative) GeV**2
36754 C. S = (c.m energy)**2 GeV**2
36755 C. OUTPUT = 10**-38 cm+2/GeV**2
36756 C-----------------------------------------------------
36757 REAL*8 MN, MN2, MN4, MD,MD2, MD4
36759 DATA PI /3.1415926/
36761 GF = (1.1664 * 1.97)
36769 VQ = (MN2 - MD2 - QQ)/2.
36770 VPI = (MN2 + MD2 - QQ)/2.
36771 VK = (S + QQ - MN2 - AML2)/2.
36773 QK = (AML2 - QQ)/2.
36774 PIQ = (QQ + MN2 - MD2)/2.
36776 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36777 C3 = SQRT(3.)*C3V/MN
36778 C4 = -C3/MD ! attenzione al segno
36779 C5A = 1.18/(1.-QQ/0.4225)**2
36784 IF (LNU .EQ. 1) THEN
36785 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36786 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36787 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36788 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36789 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36790 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36791 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36792 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36793 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36794 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36795 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36796 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36797 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36798 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36799 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36800 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36801 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36802 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36803 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36804 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36805 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36806 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36807 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36809 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36810 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36811 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36812 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36813 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36814 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36815 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36816 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36817 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36818 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36819 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36820 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36821 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36822 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36823 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36824 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36825 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36826 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36827 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36828 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36829 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36830 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36831 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36835 P1CM = (S-MN2)/(2.*SQRT(S))
36836 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36841 *$ CREATE DT_QGAUS.FOR
36844 *===qgaus==============================================================*
36846 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36848 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36851 DIMENSION X(5),W(5)
36852 DATA X/.1488743389D0,.4333953941D0,
36853 & .6794095682D0,.8650633666D0,.9739065285D0
36855 DATA W/.2955242247D0,.2692667193D0,
36856 & .2190863625D0,.1494513491D0,.0666713443D0
36863 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36864 * DT_DSQEL_Q2(LTYP,ENU,XM-DX))
36871 *$ CREATE DT_DIQBRK.FOR
36874 *===diqbrk=============================================================*
36876 SUBROUTINE DT_DIQBRK
36878 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36882 PARAMETER (NMXHKK=200000)
36883 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36884 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36885 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36886 * extended event history
36887 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36888 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36891 COMMON /DTEVNO/ NEVENT,ICASCA
36893 C IF(DT_RNDM(VV).LE.0.5D0)THEN
36894 C CALL GSQBS1(NHKK)
36895 C CALL GSQBS2(NHKK)
36896 C CALL USQBS1(NHKK)
36897 C CALL USQBS2(NHKK)
36898 C CALL GSABS1(NHKK)
36899 C CALL GSABS2(NHKK)
36900 C CALL USABS1(NHKK)
36901 C CALL USABS2(NHKK)
36903 C CALL GSQBS2(NHKK)
36904 C CALL GSQBS1(NHKK)
36905 C CALL USQBS2(NHKK)
36906 C CALL USQBS1(NHKK)
36907 C CALL GSABS2(NHKK)
36908 C CALL GSABS1(NHKK)
36909 C CALL USABS2(NHKK)
36910 C CALL USABS1(NHKK)
36913 IF(DT_RNDM(VV).LE.0.5D0) THEN
36936 *$ CREATE MUSQBS2.FOR
36940 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36941 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36942 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36944 C USQBS-2 diagram (split target diquark)
36946 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36949 PARAMETER ( LINP = 10 ,
36953 PARAMETER (NMXHKK=200000)
36954 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36955 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36956 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36957 * extended event history
36958 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36959 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36961 * Lorentz-parameters of the current interaction
36962 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36963 & UMO,PPCM,EPROJ,PPROJ
36964 * diquark-breaking mechanism
36965 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36968 PARAMETER (NTMHKK= 300)
36969 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36970 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36973 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36976 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36977 COMMON /EVFLAG/ NUMEV
36979 C USQBS-2 diagram (split target diquark)
36982 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36983 C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
36985 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36986 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36988 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
36989 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36990 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36993 C Put new chains into COMMON /HKKTMP/
36998 C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37002 C IF(NUMEV.EQ.-324)THEN
37003 C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37004 C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37005 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37006 C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37011 C determine x-values of NC1T diquark
37012 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37013 XVQP=PHKK(4,NC1P)*2.D0/UMO
37015 C determine x-values of sea quark pair
37021 IF(ICOU.GE.500)THEN
37024 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37028 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37033 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37034 IF (IPIP.EQ.1) THEN
37035 XQMAX = XDIQT/2.0D0
37036 XAQMAX = 2.D0*XVQP/3.0D0
37038 XQMAX = 2.D0*XVQP/3.0D0
37039 XAQMAX = XDIQT/2.0D0
37041 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37043 C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37046 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37049 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37054 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37055 ELSEIF(IPIP.EQ.2)THEN
37056 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37059 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37060 * XDIQT,XVQP,XSQ,XSAQ
37063 C subtract xsq,xsaq from NC1T diquark and NC1P quark
37069 ELSEIF(IPIP.EQ.2)THEN
37074 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37076 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37081 IF(IVTHR.EQ.10)THEN
37084 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37089 XVTHR=XVTHRO/(201-IVTHR)
37092 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37095 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ',
37100 IF(DT_RNDM(V).LT.0.5D0)THEN
37101 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37104 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37108 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37111 C Prepare 4 momenta of new chains and chain ends
37113 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37114 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37117 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37118 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37119 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37121 C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37122 C * IP1,IP21,IP22,IPP1,IPP2)
37129 ELSEIF(IPIP.EQ.2)THEN
37139 JDAHKT(1,1)=3+IIGLU1
37141 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37142 PHKT(1,1) =PHKK(1,NC2P)
37143 PHKT(2,1) =PHKK(2,NC2P)
37144 PHKT(3,1) =PHKK(3,NC2P)
37145 PHKT(4,1) =PHKK(4,NC2P)
37146 C PHKT(5,1) =PHKK(5,NC2P)
37147 XMIST =(PHKT(4,1)**2-
37148 * PHKT(3,1)**2-PHKT(2,1)**2-
37150 IF(XMIST.GT.0.D0)THEN
37151 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37154 C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37157 VHKT(1,1) =VHKK(1,NC2P)
37158 VHKT(2,1) =VHKK(2,NC2P)
37159 VHKT(3,1) =VHKK(3,NC2P)
37160 VHKT(4,1) =VHKK(4,NC2P)
37161 WHKT(1,1) =WHKK(1,NC2P)
37162 WHKT(2,1) =WHKK(2,NC2P)
37163 WHKT(3,1) =WHKK(3,NC2P)
37164 WHKT(4,1) =WHKK(4,NC2P)
37165 C Add here IIGLU1 gluons to this chaina
37170 IF(IIGLU1.GE.1)THEN
37172 DO 61 IIG=2,2+IIGLU1-1
37174 IDHKT(IIG) =IDHKK(KKG)
37178 JDAHKT(1,IIG)=3+IIGLU1
37180 PHKT(1,IIG)=PHKK(1,KKG)
37181 PG1=PG1+ PHKT(1,IIG)
37182 PHKT(2,IIG)=PHKK(2,KKG)
37183 PG2=PG2+ PHKT(2,IIG)
37184 PHKT(3,IIG)=PHKK(3,KKG)
37185 PG3=PG3+ PHKT(3,IIG)
37186 PHKT(4,IIG)=PHKK(4,KKG)
37187 PG4=PG4+ PHKT(4,IIG)
37188 PHKT(5,IIG)=PHKK(5,KKG)
37189 VHKT(1,IIG) =VHKK(1,KKG)
37190 VHKT(2,IIG) =VHKK(2,KKG)
37191 VHKT(3,IIG) =VHKK(3,KKG)
37192 VHKT(4,IIG) =VHKK(4,KKG)
37193 WHKT(1,IIG) =WHKK(1,KKG)
37194 WHKT(2,IIG) =WHKK(2,KKG)
37195 WHKT(3,IIG) =WHKK(3,KKG)
37196 WHKT(4,IIG) =WHKK(4,KKG)
37199 IDHKT(2+IIGLU1) =IP21
37200 ISTHKT(2+IIGLU1) =952
37201 JMOHKT(1,2+IIGLU1)=NC1T
37202 JMOHKT(2,2+IIGLU1)=0
37203 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37204 JDAHKT(2,2+IIGLU1)=0
37205 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37206 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37207 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37208 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37209 C PHKT(5,2) =PHKK(5,NC1T)
37210 XMIST =(PHKT(4,2+IIGLU1)**2-
37211 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37212 *PHKT(1,2+IIGLU1)**2)
37213 IF(XMIST.GT.0.D0)THEN
37214 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37215 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37216 *PHKT(1,2+IIGLU1)**2)
37218 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37219 PHKT(5,5+IIGLU1)=0.D0
37221 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
37222 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
37223 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
37224 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
37225 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
37226 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
37227 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
37228 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
37229 IDHKT(3+IIGLU1) =88888
37230 ISTHKT(3+IIGLU1) =95
37231 JMOHKT(1,3+IIGLU1)=1
37232 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37233 JDAHKT(1,3+IIGLU1)=0
37234 JDAHKT(2,3+IIGLU1)=0
37235 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37236 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37237 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37238 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37240 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37241 * -PHKT(3,3+IIGLU1)**2)
37242 IF(XMIST.GT.0.D0)THEN
37244 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37245 * -PHKT(3,3+IIGLU1)**2)
37247 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37248 PHKT(5,5+IIGLU1)=0.D0
37251 C IF(NUMEV.EQ.-324)THEN
37252 C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37254 C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37255 DO 71 IIG=2,2+IIGLU1-1
37256 C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37257 C & JMOHKT(1,IIG),JMOHKT(2,IIG),
37259 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37261 C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37262 C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37263 C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37264 C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37265 C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37266 C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37270 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37271 ELSEIF(IPIP.EQ.2)THEN
37272 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37274 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37278 C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37281 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37282 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37283 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37284 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37285 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37286 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37287 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37288 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37290 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37291 ELSEIF(IPIP.EQ.2)THEN
37292 IDHKT(4+IIGLU1) =ISAQ1
37294 ISTHKT(4+IIGLU1) =951
37295 JMOHKT(1,4+IIGLU1)=NC1P
37296 JMOHKT(2,4+IIGLU1)=0
37297 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37298 JDAHKT(2,4+IIGLU1)=0
37299 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37300 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37301 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37302 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37303 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37304 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37305 XMIST =(PHKT(4,4+IIGLU1)**2-
37306 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37307 *PHKT(1,4+IIGLU1)**2)
37308 IF(XMIST.GT.0.D0)THEN
37309 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37310 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37311 *PHKT(1,4+IIGLU1)**2)
37313 C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37314 PHKT(5,4+IIGLU1)=0.D0
37316 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37317 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37318 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37319 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37320 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37321 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37322 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37323 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37324 IDHKT(5+IIGLU1) =IP22
37325 ISTHKT(5+IIGLU1) =952
37326 JMOHKT(1,5+IIGLU1)=NC1T
37327 JMOHKT(2,5+IIGLU1)=0
37328 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37329 JDAHKT(2,5+IIGLU1)=0
37330 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37331 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37332 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37333 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37334 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37335 XMIST =(PHKT(4,5+IIGLU1)**2-
37336 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37337 *PHKT(1,5+IIGLU1)**2)
37338 IF(XMIST.GT.0.D0)THEN
37339 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37340 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37341 *PHKT(1,5+IIGLU1)**2)
37343 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37344 PHKT(5,5+IIGLU1)=0.D0
37346 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37347 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37348 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37349 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37350 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37351 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37352 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37353 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37354 IDHKT(6+IIGLU1) =88888
37355 ISTHKT(6+IIGLU1) =95
37356 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37357 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37358 JDAHKT(1,6+IIGLU1)=0
37359 JDAHKT(2,6+IIGLU1)=0
37360 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37361 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37362 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37363 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37365 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37366 * -PHKT(3,6+IIGLU1)**2)
37367 IF(XMIST.GT.0.D0)THEN
37369 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37370 * -PHKT(3,6+IIGLU1)**2)
37372 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37373 PHKT(5,5+IIGLU1)=0.D0
37375 C IF(IPIP.GE.2)THEN
37376 C IF(NUMEV.EQ.-324)THEN
37377 C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37378 C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37379 C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37380 C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37381 C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37382 C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37383 C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37384 C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37385 C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37389 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37390 ELSEIF(IPIP.EQ.2)THEN
37391 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37393 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37397 C WRITE(6,*)' MUSQBS1 jump back from chain 6',
37398 C * CHAMAL,PHKT(5,6+IIGLU1)
37401 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37402 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37403 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37404 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37405 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37406 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37407 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37408 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37409 C IDHKT(7) =1000*IPP1+100*ISQ+1
37410 IDHKT(7+IIGLU1) =IP1
37411 ISTHKT(7+IIGLU1) =951
37412 JMOHKT(1,7+IIGLU1)=NC1P
37413 JMOHKT(2,7+IIGLU1)=0
37415 C JDAHKT(1,7+IIGLU1)=9+IIGLU1
37416 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37418 JDAHKT(2,7+IIGLU1)=0
37419 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37420 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37421 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37422 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37423 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
37424 XMIST =(PHKT(4,7+IIGLU1)**2-
37425 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37426 *PHKT(1,7+IIGLU1)**2)
37427 IF(XMIST.GT.0.D0)THEN
37428 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37429 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37430 *PHKT(1,7+IIGLU1)**2)
37432 C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37433 PHKT(5,7+IIGLU1)=0.D0
37435 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
37436 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
37437 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
37438 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
37439 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
37440 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
37441 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
37442 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37443 C Insert here the IIGLU2 gluons
37448 IF(IIGLU2.GE.1)THEN
37450 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37451 KKG=JJG+IIG-7-IIGLU1
37452 IDHKT(IIG) =IDHKK(KKG)
37456 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37458 PHKT(1,IIG)=PHKK(1,KKG)
37459 PG1=PG1+ PHKT(1,IIG)
37460 PHKT(2,IIG)=PHKK(2,KKG)
37461 PG2=PG2+ PHKT(2,IIG)
37462 PHKT(3,IIG)=PHKK(3,KKG)
37463 PG3=PG3+ PHKT(3,IIG)
37464 PHKT(4,IIG)=PHKK(4,KKG)
37465 PG4=PG4+ PHKT(4,IIG)
37466 PHKT(5,IIG)=PHKK(5,KKG)
37467 VHKT(1,IIG) =VHKK(1,KKG)
37468 VHKT(2,IIG) =VHKK(2,KKG)
37469 VHKT(3,IIG) =VHKK(3,KKG)
37470 VHKT(4,IIG) =VHKK(4,KKG)
37471 WHKT(1,IIG) =WHKK(1,KKG)
37472 WHKT(2,IIG) =WHKK(2,KKG)
37473 WHKT(3,IIG) =WHKK(3,KKG)
37474 WHKT(4,IIG) =WHKK(4,KKG)
37478 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
37479 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37480 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37481 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37482 ELSEIF(IPIP.EQ.2)THEN
37483 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
37484 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37485 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37486 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37488 ISTHKT(8+IIGLU1+IIGLU2) =952
37489 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37490 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37491 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37492 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37493 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
37494 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37495 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
37496 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37497 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
37498 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37499 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
37500 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37501 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37502 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37503 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37505 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37506 C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37511 C PHKT(5,8) =PHKK(5,NC2T)
37512 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37513 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37514 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37515 IF(XMIST.GT.0.D0)THEN
37516 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37517 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37518 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37520 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37521 PHKT(5,5+IIGLU1)=0.D0
37523 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
37524 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
37525 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
37526 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
37527 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
37528 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
37529 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
37530 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
37531 IDHKT(9+IIGLU1+IIGLU2) =88888
37532 ISTHKT(9+IIGLU1+IIGLU2) =95
37533 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37534 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37535 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37536 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37538 C PHKT(1,9+IIGLU1+IIGLU2)
37539 C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37540 C PHKT(2,9+IIGLU1+IIGLU2)
37541 C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37542 C PHKT(3,9+IIGLU1+IIGLU2)
37543 C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37544 C PHKT(4,9+IIGLU1+IIGLU2)
37545 C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37546 PHKT(1,9+IIGLU1+IIGLU2)
37547 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37548 PHKT(2,9+IIGLU1+IIGLU2)
37549 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37550 PHKT(3,9+IIGLU1+IIGLU2)
37551 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37552 PHKT(4,9+IIGLU1+IIGLU2)
37553 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37556 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37557 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37558 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37559 IF(XMIST.GT.0.D0)THEN
37560 PHKT(5,9+IIGLU1+IIGLU2)
37561 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37562 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37563 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37565 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37566 PHKT(5,5+IIGLU1)=0.D0
37569 C IF(NUMEV.EQ.-324)THEN
37570 C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37571 C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37572 C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37573 C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37574 C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37576 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37578 C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37579 C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37580 C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37581 C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37582 C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37583 C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37584 C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37585 C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37589 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37590 ELSEIF(IPIP.EQ.2)THEN
37591 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37593 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37597 C WRITE(6,*)' MUSQBS1 jump back from chain 9',
37598 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37601 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37602 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37603 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37604 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37605 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37606 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37607 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37608 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37611 IGCOUN=9+IIGLU1+IIGLU2
37615 *$ CREATE MGSQBS2.FOR
37619 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37620 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37621 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37623 C GSQBS-2 diagram (split target diquark)
37625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37628 PARAMETER ( LINP = 10 ,
37632 PARAMETER (NMXHKK=200000)
37633 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37634 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37635 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37636 * extended event history
37637 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37638 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37640 * Lorentz-parameters of the current interaction
37641 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37642 & UMO,PPCM,EPROJ,PPROJ
37643 * diquark-breaking mechanism
37644 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37647 PARAMETER (NTMHKK= 300)
37648 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37649 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37653 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37656 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37658 C GSQBS-2 diagram (split target diquark)
37661 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37662 C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37664 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37665 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37667 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37668 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37669 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37673 C Put new chains into COMMON /HKKTMP/
37678 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37681 C IF(IPIP.EQ.2)THEN
37682 C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37683 C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37684 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37685 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37690 C determine x-values of NC1T diquark
37691 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37692 XVQP=PHKK(4,NC1P)*2.D0/UMO
37694 C determine x-values of sea quark pair
37700 IF(ICOU.GE.500)THEN
37704 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37709 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37714 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37715 IF (IPIP.EQ.1) THEN
37716 XQMAX = XDIQT/2.0D0
37717 XAQMAX = 2.D0*XVQP/3.0D0
37719 XQMAX = 2.D0*XVQP/3.0D0
37720 XAQMAX = XDIQT/2.0D0
37722 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37724 C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37727 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37730 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37735 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37736 ELSEIF(IPIP.EQ.2)THEN
37737 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37740 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37741 * XDIQT,XVQP,XSQ,XSAQ
37744 C subtract xsq,xsaq from NC1T diquark and NC1P quark
37750 ELSEIF(IPIP.EQ.2)THEN
37755 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37757 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37762 IF(IVTHR.EQ.10)THEN
37765 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37770 XVTHR=XVTHRO/(201-IVTHR)
37773 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37776 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ',
37781 IF(DT_RNDM(V).LT.0.5D0)THEN
37782 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37785 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37789 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37792 C Prepare 4 momenta of new chains and chain ends
37794 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37795 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37798 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37799 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37800 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37802 C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37803 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37810 ELSEIF(IPIP.EQ.2)THEN
37817 C IDHKT(1) =1000*IPP11+100*IPP12+1
37822 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37823 ELSEIF(IPIP.EQ.2)THEN
37824 IDHKT(4+IIGLU1) =ISAQ1
37826 ISTHKT(4+IIGLU1) =961
37827 JMOHKT(1,4+IIGLU1)=NC1P
37828 JMOHKT(2,4+IIGLU1)=0
37829 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37830 JDAHKT(2,4+IIGLU1)=0
37831 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37832 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37833 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37834 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37835 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37836 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37837 XXMIST=(PHKT(4,4+IIGLU1)**2-
37838 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37839 *PHKT(1,4+IIGLU1)**2)
37840 IF(XXMIST.GT.0.D0)THEN
37841 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37843 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37845 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37847 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37848 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37849 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37850 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37851 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37852 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37853 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37854 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37855 IDHKT(5+IIGLU1) =IP22
37856 ISTHKT(5+IIGLU1) =962
37857 JMOHKT(1,5+IIGLU1)=NC1T
37858 JMOHKT(2,5+IIGLU1)=0
37859 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37860 JDAHKT(2,5+IIGLU1)=0
37861 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37862 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37863 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37864 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37865 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37866 XXMIST=(PHKT(4,5+IIGLU1)**2-
37867 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37868 *PHKT(1,5+IIGLU1)**2)
37869 IF(XXMIST.GT.0.D0)THEN
37870 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37872 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37874 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37876 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37877 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37878 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37879 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37880 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37881 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37882 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37883 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37884 IDHKT(6+IIGLU1) =88888
37885 ISTHKT(6+IIGLU1) =96
37886 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37887 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37888 JDAHKT(1,6+IIGLU1)=0
37889 JDAHKT(2,6+IIGLU1)=0
37890 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37891 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37892 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37893 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37895 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37896 * -PHKT(3,6+IIGLU1)**2)
37899 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37900 ELSEIF(IPIP.EQ.2)THEN
37901 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37903 C---------------------------------------------------
37904 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37905 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37906 C we drop chain 6 and give the energy to chain 3
37907 IDHKT(6+IIGLU1)=22888
37909 C WRITE(6,*)' drop chain 6 xgive=1'
37911 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37912 C we drop chain 6 and give the energy to chain 3
37913 C and change KK11 to IDHKT(5)
37914 IDHKT(6+IIGLU1)=22888
37916 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37917 KK11=IDHKT(5+IIGLU1)
37919 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37920 C we drop chain 6 and give the energy to chain 3
37921 C and change KK21 to IDHKT(5+IIGLU1)
37922 C IDHKT(1) =1000*IPP11+100*IPP12+1
37923 IDHKT(6+IIGLU1)=22888
37925 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37926 KK21=IDHKT(5+IIGLU1)
37928 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37929 C we drop chain 6 and give the energy to chain 3
37930 C and change KK22 to IDHKT(5)
37931 C IDHKT(1) =1000*IPP11+100*IPP12+1
37932 IDHKT(6+IIGLU1)=22888
37934 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37935 KK22=IDHKT(5+IIGLU1)
37944 C---------------------------------------------------
37946 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37947 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37948 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37949 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37950 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37951 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37952 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37953 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37954 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37956 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37957 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37958 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37959 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37960 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37961 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37962 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37963 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37964 C IDHKT(1) =1000*IPP11+100*IPP12+1
37966 IDHKT(1) =1000*KK21+100*KK22+3
37967 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
37968 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
37969 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
37970 ELSEIF(IPIP.EQ.2)THEN
37971 IDHKT(1) =1000*KK21+100*KK22-3
37972 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
37973 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
37974 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
37979 JDAHKT(1,1)=3+IIGLU1
37981 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37982 PHKT(1,1) =PHKK(1,NC2P)
37983 *+XGIVE*PHKT(1,4+IIGLU1)
37984 PHKT(2,1) =PHKK(2,NC2P)
37985 *+XGIVE*PHKT(2,4+IIGLU1)
37986 PHKT(3,1) =PHKK(3,NC2P)
37987 *+XGIVE*PHKT(3,4+IIGLU1)
37988 PHKT(4,1) =PHKK(4,NC2P)
37989 *+XGIVE*PHKT(4,4+IIGLU1)
37990 C PHKT(5,1) =PHKK(5,NC2P)
37991 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37993 IF(XXMIST.GT.0.D0)THEN
37994 PHKT(5,1) =SQRT(XXMIST)
37996 WRITE(LOUT,*)'MGSQBS2',XXMIST
37998 PHKT(5,1) =SQRT(XXMIST)
38000 VHKT(1,1) =VHKK(1,NC2P)
38001 VHKT(2,1) =VHKK(2,NC2P)
38002 VHKT(3,1) =VHKK(3,NC2P)
38003 VHKT(4,1) =VHKK(4,NC2P)
38004 WHKT(1,1) =WHKK(1,NC2P)
38005 WHKT(2,1) =WHKK(2,NC2P)
38006 WHKT(3,1) =WHKK(3,NC2P)
38007 WHKT(4,1) =WHKK(4,NC2P)
38008 C Add here IIGLU1 gluons to this chaina
38013 IF(IIGLU1.GE.1)THEN
38015 DO 61 IIG=2,2+IIGLU1-1
38017 IDHKT(IIG) =IDHKK(KKG)
38021 JDAHKT(1,IIG)=3+IIGLU1
38023 PHKT(1,IIG)=PHKK(1,KKG)
38024 PG1=PG1+ PHKT(1,IIG)
38025 PHKT(2,IIG)=PHKK(2,KKG)
38026 PG2=PG2+ PHKT(2,IIG)
38027 PHKT(3,IIG)=PHKK(3,KKG)
38028 PG3=PG3+ PHKT(3,IIG)
38029 PHKT(4,IIG)=PHKK(4,KKG)
38030 PG4=PG4+ PHKT(4,IIG)
38031 PHKT(5,IIG)=PHKK(5,KKG)
38032 VHKT(1,IIG) =VHKK(1,KKG)
38033 VHKT(2,IIG) =VHKK(2,KKG)
38034 VHKT(3,IIG) =VHKK(3,KKG)
38035 VHKT(4,IIG) =VHKK(4,KKG)
38036 WHKT(1,IIG) =WHKK(1,KKG)
38037 WHKT(2,IIG) =WHKK(2,KKG)
38038 WHKT(3,IIG) =WHKK(3,KKG)
38039 WHKT(4,IIG) =WHKK(4,KKG)
38043 IDHKT(2+IIGLU1) =KK11
38044 ISTHKT(2+IIGLU1) =962
38045 JMOHKT(1,2+IIGLU1)=NC1T
38046 JMOHKT(2,2+IIGLU1)=0
38047 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38048 JDAHKT(2,2+IIGLU1)=0
38049 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38050 C * +0.5D0*PHKK(1,NC2T)
38051 *+XGIVE*PHKT(1,5+IIGLU1)
38052 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38053 C *+0.5D0*PHKK(2,NC2T)
38054 *+XGIVE*PHKT(2,5+IIGLU1)
38055 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38056 C *+0.5D0*PHKK(3,NC2T)
38057 *+XGIVE*PHKT(3,5+IIGLU1)
38058 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38059 C *+0.5D0*PHKK(4,NC2T)
38060 *+XGIVE*PHKT(4,5+IIGLU1)
38061 C PHKT(5,2) =PHKK(5,NC1T)
38062 XXMIST=(PHKT(4,2+IIGLU1)**2-
38063 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38064 *PHKT(1,2+IIGLU1)**2)
38065 IF(XXMIST.GT.0.D0)THEN
38066 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38068 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38070 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38072 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
38073 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
38074 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
38075 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
38076 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
38077 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
38078 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
38079 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
38080 IDHKT(3+IIGLU1) =88888
38081 ISTHKT(3+IIGLU1) =96
38082 JMOHKT(1,3+IIGLU1)=1
38083 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38084 JDAHKT(1,3+IIGLU1)=0
38085 JDAHKT(2,3+IIGLU1)=0
38086 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38087 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38088 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38089 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38091 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38092 * -PHKT(3,3+IIGLU1)**2)
38094 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38096 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38097 DO 71 IIG=2,2+IIGLU1-1
38098 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38099 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38101 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38103 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38104 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38105 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38106 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38107 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38108 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38112 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38113 ELSEIF(IPIP.EQ.2)THEN
38114 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38116 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38122 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38123 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38124 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38125 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38126 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38127 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38128 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38129 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38130 C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
38131 IDHKT(7+IIGLU1) =IP1
38132 ISTHKT(7+IIGLU1) =961
38133 JMOHKT(1,7+IIGLU1)=NC1P
38134 JMOHKT(2,7+IIGLU1)=0
38135 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38136 JDAHKT(2,7+IIGLU1)=0
38137 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38138 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38139 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38140 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38141 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
38142 XXMIST=(PHKT(4,7+IIGLU1)**2-
38143 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38144 *PHKT(1,7+IIGLU1)**2)
38145 IF(XXMIST.GT.0.D0)THEN
38146 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38148 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38150 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38152 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
38153 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
38154 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
38155 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
38156 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
38157 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
38158 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
38159 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38160 C IDHKT(7) =1000*IPP1+100*ISQ+1
38161 C Insert here the IIGLU2 gluons
38166 IF(IIGLU2.GE.1)THEN
38168 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38169 KKG=JJG+IIG-7-IIGLU1
38170 IDHKT(IIG) =IDHKK(KKG)
38174 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38176 PHKT(1,IIG)=PHKK(1,KKG)
38177 PG1=PG1+ PHKT(1,IIG)
38178 PHKT(2,IIG)=PHKK(2,KKG)
38179 PG2=PG2+ PHKT(2,IIG)
38180 PHKT(3,IIG)=PHKK(3,KKG)
38181 PG3=PG3+ PHKT(3,IIG)
38182 PHKT(4,IIG)=PHKK(4,KKG)
38183 PG4=PG4+ PHKT(4,IIG)
38184 PHKT(5,IIG)=PHKK(5,KKG)
38185 VHKT(1,IIG) =VHKK(1,KKG)
38186 VHKT(2,IIG) =VHKK(2,KKG)
38187 VHKT(3,IIG) =VHKK(3,KKG)
38188 VHKT(4,IIG) =VHKK(4,KKG)
38189 WHKT(1,IIG) =WHKK(1,KKG)
38190 WHKT(2,IIG) =WHKK(2,KKG)
38191 WHKT(3,IIG) =WHKK(3,KKG)
38192 WHKT(4,IIG) =WHKK(4,KKG)
38196 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
38197 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38198 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38199 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38200 ELSEIF(IPIP.EQ.2)THEN
38202 C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
38203 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
38205 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38206 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38207 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38209 ISTHKT(8+IIGLU1+IIGLU2) =962
38210 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38211 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38212 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38213 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38214 C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38215 C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38216 C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38217 C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38218 PHKT(1,8+IIGLU1+IIGLU2) =
38219 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38220 PHKT(2,8+IIGLU1+IIGLU2) =
38221 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38222 PHKT(3,8+IIGLU1+IIGLU2) =
38223 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38224 PHKT(4,8+IIGLU1+IIGLU2) =
38225 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38226 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38227 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38228 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38230 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38235 C PHKT(5,8) =PHKK(5,NC2T)
38236 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38237 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38238 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38239 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
38240 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
38241 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
38242 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
38243 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
38244 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
38245 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
38246 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
38247 IDHKT(9+IIGLU1+IIGLU2) =88888
38248 ISTHKT(9+IIGLU1+IIGLU2) =96
38249 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38250 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38251 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38252 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38253 PHKT(1,9+IIGLU1+IIGLU2)
38254 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38255 PHKT(2,9+IIGLU1+IIGLU2)
38256 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38257 PHKT(3,9+IIGLU1+IIGLU2)
38258 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38259 PHKT(4,9+IIGLU1+IIGLU2)
38260 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38261 PHKT(5,9+IIGLU1+IIGLU2)
38262 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38263 * PHKT(2,9+IIGLU1+IIGLU2)**2
38264 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38266 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38267 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38268 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38269 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38270 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38271 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38273 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38275 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38276 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38277 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38278 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38279 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38280 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38281 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38282 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38286 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38287 ELSEIF(IPIP.EQ.2)THEN
38288 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38290 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38296 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38297 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38298 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38299 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38300 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38301 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38302 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38303 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38306 IGCOUN=9+IIGLU1+IIGLU2
38310 *$ CREATE MUSQBS1.FOR
38314 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38315 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38316 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38318 C USQBS-1 diagram (split projectile diquark)
38320 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38323 PARAMETER ( LINP = 10 ,
38327 PARAMETER (NMXHKK=200000)
38328 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38329 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38330 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38331 * extended event history
38332 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38333 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38335 * Lorentz-parameters of the current interaction
38336 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38337 & UMO,PPCM,EPROJ,PPROJ
38338 * diquark-breaking mechanism
38339 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38342 PARAMETER (NTMHKK= 300)
38343 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38344 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38347 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38350 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38351 COMMON /EVFLAG/ NUMEV
38353 C USQBS-1 diagram (split projectile diquark)
38355 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38356 C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38358 C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38359 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38361 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38362 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38363 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38365 C Put new chains into COMMON /HKKTMP/
38370 C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38374 C IF(NUMEV.EQ.-324)THEN
38375 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38376 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38377 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38378 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38383 C determine x-values of NC1P diquark
38384 XDIQP=PHKK(4,NC1P)*2.D0/UMO
38385 XVQT=PHKK(4,NC1T)*2.D0/UMO
38387 C determine x-values of sea quark pair
38393 IF(ICOU.GE.500)THEN
38396 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38400 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
38405 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38406 IF (IPIP.EQ.1) THEN
38407 XQMAX = XDIQP/2.0D0
38408 XAQMAX = 2.D0*XVQT/3.0D0
38410 XQMAX = 2.D0*XVQT/3.0D0
38411 XAQMAX = XDIQP/2.0D0
38413 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38415 C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38417 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38420 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38425 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38426 ELSEIF(IPIP.EQ.2)THEN
38427 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38430 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38431 * XDIQP,XVQT,XSQ,XSAQ
38434 C subtract xsq,xsaq from NC1P diquark and NC1T quark
38440 ELSEIF(IPIP.EQ.2)THEN
38445 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38447 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38452 IF(IVTHR.EQ.10)THEN
38455 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38460 XVTHR=XVTHRO/(201-IVTHR)
38463 IF(XVTHR.GT.0.66D0*XDIQP)THEN
38466 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ',
38471 IF(DT_RNDM(V).LT.0.5D0)THEN
38472 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38475 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38479 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38482 C Prepare 4 momenta of new chains and chain ends
38484 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38485 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38487 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38488 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38489 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38495 ELSEIF(IPIP.EQ.2)THEN
38505 JDAHKT(1,1)=3+IIGLU1
38507 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38508 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38509 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38510 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38511 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38512 C PHKT(5,1) =PHKK(5,NC1P)
38513 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38515 IF(XMIST.GE.0.D0)THEN
38516 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38519 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38522 VHKT(1,1) =VHKK(1,NC1P)
38523 VHKT(2,1) =VHKK(2,NC1P)
38524 VHKT(3,1) =VHKK(3,NC1P)
38525 VHKT(4,1) =VHKK(4,NC1P)
38526 WHKT(1,1) =WHKK(1,NC1P)
38527 WHKT(2,1) =WHKK(2,NC1P)
38528 WHKT(3,1) =WHKK(3,NC1P)
38529 WHKT(4,1) =WHKK(4,NC1P)
38530 C Add here IIGLU1 gluons to this chaina
38535 IF(IIGLU1.GE.1)THEN
38537 DO 61 IIG=2,2+IIGLU1-1
38539 IDHKT(IIG) =IDHKK(KKG)
38543 JDAHKT(1,IIG)=3+IIGLU1
38545 PHKT(1,IIG)=PHKK(1,KKG)
38546 PG1=PG1+ PHKT(1,IIG)
38547 PHKT(2,IIG)=PHKK(2,KKG)
38548 PG2=PG2+ PHKT(2,IIG)
38549 PHKT(3,IIG)=PHKK(3,KKG)
38550 PG3=PG3+ PHKT(3,IIG)
38551 PHKT(4,IIG)=PHKK(4,KKG)
38552 PG4=PG4+ PHKT(4,IIG)
38553 PHKT(5,IIG)=PHKK(5,KKG)
38554 VHKT(1,IIG) =VHKK(1,KKG)
38555 VHKT(2,IIG) =VHKK(2,KKG)
38556 VHKT(3,IIG) =VHKK(3,KKG)
38557 VHKT(4,IIG) =VHKK(4,KKG)
38558 WHKT(1,IIG) =WHKK(1,KKG)
38559 WHKT(2,IIG) =WHKK(2,KKG)
38560 WHKT(3,IIG) =WHKK(3,KKG)
38561 WHKT(4,IIG) =WHKK(4,KKG)
38564 IDHKT(2+IIGLU1) =IPP2
38565 ISTHKT(2+IIGLU1) =932
38566 JMOHKT(1,2+IIGLU1)=NC2T
38567 JMOHKT(2,2+IIGLU1)=0
38568 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38569 JDAHKT(2,2+IIGLU1)=0
38570 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38571 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38572 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38573 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38574 C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
38575 XMIST=(PHKT(4,2+IIGLU1)**2-
38576 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38577 *PHKT(1,2+IIGLU1)**2)
38578 IF(XMIST.GT.0.D0)THEN
38579 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38580 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38581 *PHKT(1,2+IIGLU1)**2)
38583 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38584 PHKT(5,2+IIGLU1)=0.D0
38586 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38587 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38588 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38589 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38590 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38591 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38592 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38593 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38594 IDHKT(3+IIGLU1) =88888
38595 ISTHKT(3+IIGLU1) =94
38596 JMOHKT(1,3+IIGLU1)=1
38597 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38598 JDAHKT(1,3+IIGLU1)=0
38599 JDAHKT(2,3+IIGLU1)=0
38600 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38601 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38602 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38603 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38605 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38606 * -PHKT(3,3+IIGLU1)**2)
38607 IF(XMIST.GE.0.D0)THEN
38609 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38610 * -PHKT(3,3+IIGLU1)**2)
38612 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38616 C IF(NUMEV.EQ.-324)THEN
38617 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38618 * JMOHKT(2,1),JDAHKT(1,1),
38619 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38620 DO 71 IIG=2,2+IIGLU1-1
38621 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38622 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38624 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38626 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38627 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38628 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38629 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38630 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38631 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38635 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38636 ELSEIF(IPIP.EQ.2)THEN
38637 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38639 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38643 C WRITE(6,*)' MUSQBS1 jump back from chain 3'
38646 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38647 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38648 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38649 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38650 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38651 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38652 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38653 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38654 IDHKT(4+IIGLU1) =IP12
38655 ISTHKT(4+IIGLU1) =931
38656 JMOHKT(1,4+IIGLU1)=NC1P
38657 JMOHKT(2,4+IIGLU1)=0
38658 JDAHKT(1,4+IIGLU1)=6+IIGLU1
38659 JDAHKT(2,4+IIGLU1)=0
38660 C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38661 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38662 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38663 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38664 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38665 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
38666 XMIST =(PHKT(4,4+IIGLU1)**2-
38667 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38668 *PHKT(1,4+IIGLU1)**2)
38669 IF(XMIST.GT.0.D0)THEN
38670 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
38671 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38672 *PHKT(1,4+IIGLU1)**2)
38674 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38675 PHKT(5,4+IIGLU1)=0.D0
38677 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
38678 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
38679 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
38680 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
38681 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
38682 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
38683 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
38684 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
38686 IDHKT(5+IIGLU1) =-(ISAQ1-6)
38687 ELSEIF(IPIP.EQ.2)THEN
38688 IDHKT(5+IIGLU1) =ISAQ1
38690 ISTHKT(5+IIGLU1) =932
38691 JMOHKT(1,5+IIGLU1)=NC1T
38692 JMOHKT(2,5+IIGLU1)=0
38693 JDAHKT(1,5+IIGLU1)=6+IIGLU1
38694 JDAHKT(2,5+IIGLU1)=0
38695 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38696 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38697 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38698 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38699 C IF( PHKT(4,5).EQ.0.D0)THEN
38704 C PHKT(5,5) =PHKK(5,NC1T)
38705 XMIST=(PHKT(4,5+IIGLU1)**2-
38706 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38707 *PHKT(1,5+IIGLU1)**2)
38708 IF(XMIST.GT.0.D0)THEN
38709 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
38710 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38711 *PHKT(1,5+IIGLU1)**2)
38713 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38714 PHKT(5,5+IIGLU1)=0.D0
38716 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
38717 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
38718 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
38719 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
38720 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
38721 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
38722 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
38723 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
38724 IDHKT(6+IIGLU1) =88888
38725 ISTHKT(6+IIGLU1) =94
38726 JMOHKT(1,6+IIGLU1)=4+IIGLU1
38727 JMOHKT(2,6+IIGLU1)=5+IIGLU1
38728 JDAHKT(1,6+IIGLU1)=0
38729 JDAHKT(2,6+IIGLU1)=0
38730 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38731 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38732 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38733 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38735 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38736 * -PHKT(3,6+IIGLU1)**2)
38737 IF(XMIST.GE.0.D0)THEN
38739 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38740 * -PHKT(3,6+IIGLU1)**2)
38742 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38745 C IF(IPIP.EQ.3)THEN
38748 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38749 ELSEIF(IPIP.EQ.2)THEN
38750 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38752 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38756 C WRITE(6,*)' MGSQBS1 jump back from chain 6',
38757 C * CHAMAL,PHKT(5,6+IIGLU1)
38761 C IF(NUMEV.EQ.-324)THEN
38762 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38763 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38764 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38765 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38766 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38767 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38768 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38769 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38770 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38772 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38773 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38774 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38775 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38776 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38777 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38778 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38779 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38781 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
38782 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38783 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38784 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38785 ELSEIF(IPIP.EQ.2)THEN
38786 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38787 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38788 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38789 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38790 C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38792 ISTHKT(7+IIGLU1) =931
38793 JMOHKT(1,7+IIGLU1)=NC2P
38794 JMOHKT(2,7+IIGLU1)=0
38795 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38796 JDAHKT(2,7+IIGLU1)=0
38797 C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38798 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38799 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38800 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38801 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38802 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38803 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38804 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38806 C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38811 C PHKT(5,7) =PHKK(5,NC2P)
38812 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38813 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38814 *PHKT(1,7+IIGLU1)**2)
38815 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38816 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38817 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38818 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38819 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38820 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38821 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38822 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38823 C Insert here the IIGLU2 gluons
38828 IF(IIGLU2.GE.1)THEN
38830 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38831 KKG=JJG+IIG-7-IIGLU1
38832 IDHKT(IIG) =IDHKK(KKG)
38836 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38838 PHKT(1,IIG)=PHKK(1,KKG)
38839 PG1=PG1+ PHKT(1,IIG)
38840 PHKT(2,IIG)=PHKK(2,KKG)
38841 PG2=PG2+ PHKT(2,IIG)
38842 PHKT(3,IIG)=PHKK(3,KKG)
38843 PG3=PG3+ PHKT(3,IIG)
38844 PHKT(4,IIG)=PHKK(4,KKG)
38845 PG4=PG4+ PHKT(4,IIG)
38846 PHKT(5,IIG)=PHKK(5,KKG)
38847 VHKT(1,IIG) =VHKK(1,KKG)
38848 VHKT(2,IIG) =VHKK(2,KKG)
38849 VHKT(3,IIG) =VHKK(3,KKG)
38850 VHKT(4,IIG) =VHKK(4,KKG)
38851 WHKT(1,IIG) =WHKK(1,KKG)
38852 WHKT(2,IIG) =WHKK(2,KKG)
38853 WHKT(3,IIG) =WHKK(3,KKG)
38854 WHKT(4,IIG) =WHKK(4,KKG)
38857 IDHKT(8+IIGLU1+IIGLU2) =IP2
38858 ISTHKT(8+IIGLU1+IIGLU2) =932
38859 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38860 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38861 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38862 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38863 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38864 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38865 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38866 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38867 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38868 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38869 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38870 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38871 IF(XMIST.GT.0.D0)THEN
38872 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38873 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38874 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38876 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38877 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38879 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38880 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38881 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38882 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38883 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38884 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38885 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38886 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38887 IDHKT(9+IIGLU1+IIGLU2) =88888
38888 ISTHKT(9+IIGLU1+IIGLU2) =94
38889 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38890 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38891 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38892 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38893 PHKT(1,9+IIGLU1+IIGLU2)
38894 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38895 PHKT(2,9+IIGLU1+IIGLU2)
38896 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38897 PHKT(3,9+IIGLU1+IIGLU2)
38898 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38899 PHKT(4,9+IIGLU1+IIGLU2)
38900 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38902 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38903 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38904 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38905 IF(XMIST.GE.0.D0)THEN
38906 PHKT(5,9+IIGLU1+IIGLU2)
38907 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38908 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38909 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38911 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38915 C IF(NUMEV.EQ.-324)THEN
38916 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38917 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38918 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38919 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38920 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38921 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38923 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38925 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38926 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38927 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38928 *JDAHKT(1,8+IIGLU1+IIGLU2),
38929 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38930 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38931 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38932 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38933 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38937 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38938 ELSEIF(IPIP.EQ.2)THEN
38939 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38941 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38945 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38946 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38949 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38950 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38951 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38952 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38953 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38954 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38955 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38956 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38959 IGCOUN=9+IIGLU1+IIGLU2
38963 *$ CREATE MGSQBS1.FOR
38966 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38967 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38968 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
38970 C GSQBS-1 diagram (split projectile diquark)
38972 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38975 PARAMETER ( LINP = 10 ,
38979 PARAMETER (NMXHKK=200000)
38980 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38981 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38982 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38983 * extended event history
38984 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38985 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38987 * Lorentz-parameters of the current interaction
38988 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38989 & UMO,PPCM,EPROJ,PPROJ
38990 * diquark-breaking mechanism
38991 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38994 PARAMETER (NTMHKK= 300)
38995 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38996 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38999 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39002 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39004 C GSQBS-1 diagram (split projectile diquark)
39007 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39008 C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39010 C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39011 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39013 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39014 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39015 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39017 C Put new chains into COMMON /HKKTMP/
39022 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39024 NNNC1=IDHKK(NC1)/1000
39025 MMMC1=IDHKK(NC1)-NNNC1*1000
39027 NNNC2=IDHKK(NC2)/1000
39028 MMMC2=IDHKK(NC2)-NNNC2*1000
39032 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39033 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39034 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39035 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39040 C determine x-values of NC1P diquark
39041 XDIQP=PHKK(4,NC1P)*2.D0/UMO
39042 XVQT=PHKK(4,NC1T)*2.D0/UMO
39044 C determine x-values of sea quark pair
39050 IF(ICOU.GE.500)THEN
39053 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39057 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
39062 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39063 IF (IPIP.EQ.1) THEN
39064 XQMAX = XDIQP/2.0D0
39065 XAQMAX = 2.D0*XVQT/3.0D0
39067 XQMAX = 2.D0*XVQT/3.0D0
39068 XAQMAX = XDIQP/2.0D0
39070 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39072 C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39075 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39078 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39083 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39084 ELSEIF(IPIP.EQ.2)THEN
39085 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39088 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39089 * XDIQP,XVQT,XSQ,XSAQ
39092 C subtract xsq,xsaq from NC1P diquark and NC1T quark
39098 C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39101 ELSEIF(IPIP.EQ.2)THEN
39106 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39108 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39113 IF(IVTHR.EQ.10)THEN
39116 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39121 XVTHR=XVTHRO/(201-IVTHR)
39124 IF(XVTHR.GT.0.66D0*XDIQP)THEN
39128 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ',
39133 IF(DT_RNDM(V).LT.0.5D0)THEN
39134 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39137 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39141 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39142 * XVTHR,XDIQP,XVPQI,XVPQII
39145 C Prepare 4 momenta of new chains and chain ends
39147 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39148 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39150 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39151 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39152 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39158 ELSEIF(IPIP.EQ.2)THEN
39165 C IDHKT(2) =1000*IPP21+100*IPP22+1
39169 IDHKT(4+IIGLU1) =IP12
39170 ISTHKT(4+IIGLU1) =921
39171 JMOHKT(1,4+IIGLU1)=NC1P
39172 JMOHKT(2,4+IIGLU1)=0
39173 JDAHKT(1,4+IIGLU1)=6+IIGLU1
39174 JDAHKT(2,4+IIGLU1)=0
39176 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39177 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39179 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39180 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39181 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39182 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39183 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
39184 XXMIST=(PHKT(4,4+IIGLU1)**2-
39185 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39186 * PHKT(1,4+IIGLU1)**2)
39187 IF(XXMIST.GT.0.D0)THEN
39188 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39190 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39192 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39194 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
39195 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
39196 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
39197 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
39198 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
39199 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
39200 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
39201 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
39203 IDHKT(5+IIGLU1) =-(ISAQ1-6)
39204 ELSEIF(IPIP.EQ.2)THEN
39205 IDHKT(5+IIGLU1) =ISAQ1
39207 ISTHKT(5+IIGLU1) =922
39208 JMOHKT(1,5+IIGLU1)=NC1T
39209 JMOHKT(2,5+IIGLU1)=0
39210 JDAHKT(1,5+IIGLU1)=6+IIGLU1
39211 JDAHKT(2,5+IIGLU1)=0
39213 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
39214 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39216 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39217 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39218 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39219 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39220 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
39221 XMIST=(PHKT(4,5+IIGLU1)**2-
39222 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39223 *PHKT(1,5+IIGLU1)**2)
39224 IF(XMIST.GT.0.D0)THEN
39225 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
39226 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39227 *PHKT(1,5+IIGLU1)**2)
39229 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39230 PHKT(5,5+IIGLU1)=0.D0
39232 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
39233 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
39234 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
39235 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
39236 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
39237 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
39238 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
39239 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
39240 IDHKT(6+IIGLU1) =88888
39241 C IDHKT(6) =1000*NNNC1+MMMC1
39242 ISTHKT(6+IIGLU1) =93
39244 JMOHKT(1,6+IIGLU1)=4+IIGLU1
39245 JMOHKT(2,6+IIGLU1)=5+IIGLU1
39246 JDAHKT(1,6+IIGLU1)=0
39247 JDAHKT(2,6+IIGLU1)=0
39248 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39249 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39250 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39251 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39253 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39254 * -PHKT(3,6+IIGLU1)**2)
39257 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39258 ELSEIF(IPIP.EQ.2)THEN
39259 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39261 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39262 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39263 C we drop chain 6 and give the energy to chain 3
39264 IDHKT(6+IIGLU1)=33888
39266 C WRITE(6,*)' drop chain 6 xgive=1'
39268 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39269 C we drop chain 6 and give the energy to chain 3
39270 C and change KK11 to IDHKT(4)
39271 IDHKT(6+IIGLU1)=33888
39273 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39274 KK11=IDHKT(4+IIGLU1)
39276 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39277 C we drop chain 6 and give the energy to chain 3
39278 C and change KK21 to IDHKT(4)
39279 C IDHKT(2) =1000*IPP21+100*IPP22+1
39280 IDHKT(6+IIGLU1)=33888
39282 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39283 KK21=IDHKT(4+IIGLU1)
39285 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39286 C we drop chain 6 and give the energy to chain 3
39287 C and change KK22 to IDHKT(4)
39288 C IDHKT(2) =1000*IPP21+100*IPP22+1
39289 IDHKT(6+IIGLU1)=33888
39291 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39292 KK22=IDHKT(4+IIGLU1)
39298 C WRITE(6,*)' MGSQBS1 jump back from chain 6'
39303 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39304 * JMOHKT(1,4+IIGLU1),
39305 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39306 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39307 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39308 * JMOHKT(1,5+IIGLU1),
39309 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39310 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39311 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39312 * JMOHKT(1,6+IIGLU1),
39313 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39314 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39316 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
39317 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
39318 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
39319 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
39320 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
39321 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
39322 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
39323 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
39329 JDAHKT(1,1)=3+IIGLU1
39331 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39332 C * +0.5D0*PHKK(1,NC2P)
39333 *+XGIVE*PHKT(1,4+IIGLU1)
39334 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39335 C * +0.5D0*PHKK(2,NC2P)
39336 *+XGIVE*PHKT(2,4+IIGLU1)
39337 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39338 C * +0.5D0*PHKK(3,NC2P)
39339 *+XGIVE*PHKT(3,4+IIGLU1)
39340 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39341 C * +0.5D0*PHKK(4,NC2P)
39342 *+XGIVE*PHKT(4,4+IIGLU1)
39343 C PHKT(5,1) =PHKK(5,NC1P)
39344 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39346 IF(XMIST.GE.0.D0)THEN
39347 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39350 C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39353 VHKT(1,1) =VHKK(1,NC1P)
39354 VHKT(2,1) =VHKK(2,NC1P)
39355 VHKT(3,1) =VHKK(3,NC1P)
39356 VHKT(4,1) =VHKK(4,NC1P)
39357 WHKT(1,1) =WHKK(1,NC1P)
39358 WHKT(2,1) =WHKK(2,NC1P)
39359 WHKT(3,1) =WHKK(3,NC1P)
39360 WHKT(4,1) =WHKK(4,NC1P)
39361 C Add here IIGLU1 gluons to this chaina
39366 IF(IIGLU1.GE.1)THEN
39368 DO 61 IIG=2,2+IIGLU1-1
39370 IDHKT(IIG) =IDHKK(KKG)
39374 JDAHKT(1,IIG)=3+IIGLU1
39376 PHKT(1,IIG)=PHKK(1,KKG)
39377 PG1=PG1+ PHKT(1,IIG)
39378 PHKT(2,IIG)=PHKK(2,KKG)
39379 PG2=PG2+ PHKT(2,IIG)
39380 PHKT(3,IIG)=PHKK(3,KKG)
39381 PG3=PG3+ PHKT(3,IIG)
39382 PHKT(4,IIG)=PHKK(4,KKG)
39383 PG4=PG4+ PHKT(4,IIG)
39384 PHKT(5,IIG)=PHKK(5,KKG)
39385 VHKT(1,IIG) =VHKK(1,KKG)
39386 VHKT(2,IIG) =VHKK(2,KKG)
39387 VHKT(3,IIG) =VHKK(3,KKG)
39388 VHKT(4,IIG) =VHKK(4,KKG)
39389 WHKT(1,IIG) =WHKK(1,KKG)
39390 WHKT(2,IIG) =WHKK(2,KKG)
39391 WHKT(3,IIG) =WHKK(3,KKG)
39392 WHKT(4,IIG) =WHKK(4,KKG)
39395 C IDHKT(2) =1000*IPP21+100*IPP22+1
39397 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
39398 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39399 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39400 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39401 ELSEIF(IPIP.EQ.2)THEN
39402 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
39403 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39404 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39405 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39407 ISTHKT(2+IIGLU1) =922
39408 JMOHKT(1,2+IIGLU1)=NC2T
39409 JMOHKT(2,2+IIGLU1)=0
39410 JDAHKT(1,2+IIGLU1)=3+IIGLU1
39411 JDAHKT(2,2+IIGLU1)=0
39412 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
39413 *+XGIVE*PHKT(1,5+IIGLU1)
39414 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
39415 *+XGIVE*PHKT(2,5+IIGLU1)
39416 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
39417 *+XGIVE*PHKT(3,5+IIGLU1)
39418 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
39419 *+XGIVE*PHKT(4,5+IIGLU1)
39420 C PHKT(5,2) =PHKK(5,NC2T)
39421 XMIST=(PHKT(4,2+IIGLU1)**2-
39422 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39423 *PHKT(1,2+IIGLU1)**2)
39424 IF(XMIST.GT.0.D0)THEN
39425 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
39426 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39427 *PHKT(1,2+IIGLU1)**2)
39429 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39430 PHKT(5,2+IIGLU1)=0.D0
39432 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
39433 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
39434 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
39435 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
39436 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
39437 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
39438 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
39439 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
39440 IDHKT(3+IIGLU1) =88888
39441 C IDHKT(3) =1000*NNNC1+MMMC1+10
39442 ISTHKT(3+IIGLU1) =93
39444 JMOHKT(1,3+IIGLU1)=1
39445 JMOHKT(2,3+IIGLU1)=2+IIGLU1
39446 JDAHKT(1,3+IIGLU1)=0
39447 JDAHKT(2,3+IIGLU1)=0
39448 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39449 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39450 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39451 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39453 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39454 * -PHKT(3,3+IIGLU1)**2)
39456 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39458 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39459 DO 71 IIG=2,2+IIGLU1-1
39460 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39461 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39463 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39465 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39466 & IDHKT(2),JMOHKT(1,2+IIGLU1),
39467 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39468 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39469 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39470 * JMOHKT(1,3+IIGLU1),
39471 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39472 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39476 C IF(IPIP.EQ.1)THEN
39477 C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39478 C ELSEIF(IPIP.EQ.2)THEN
39479 C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39482 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39483 ELSEIF(IPIP.EQ.2)THEN
39484 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39487 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39491 C WRITE(6,*)' MGSQBS1 jump back from chain 3'
39494 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
39495 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
39496 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
39497 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
39498 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
39499 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
39500 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
39501 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
39503 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
39504 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39505 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39506 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39507 ELSEIF(IPIP.EQ.2)THEN
39508 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
39509 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39510 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39511 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39512 C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39514 ISTHKT(7+IIGLU1) =921
39515 JMOHKT(1,7+IIGLU1)=NC2P
39516 JMOHKT(2,7+IIGLU1)=0
39517 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39518 JDAHKT(2,7+IIGLU1)=0
39519 C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39520 C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39521 C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39522 C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39524 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39525 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39527 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39528 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39529 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39530 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39531 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39532 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39533 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39535 C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39540 C PHKT(5,7) =PHKK(5,NC2P)
39541 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
39542 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39543 *PHKT(1,7+IIGLU1)**2)
39544 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
39545 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
39546 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
39547 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
39548 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
39549 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
39550 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
39551 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
39552 C Insert here the IIGLU2 gluons
39557 IF(IIGLU2.GE.1)THEN
39559 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39560 KKG=JJG+IIG-7-IIGLU1
39561 IDHKT(IIG) =IDHKK(KKG)
39565 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39567 PHKT(1,IIG)=PHKK(1,KKG)
39568 PG1=PG1+ PHKT(1,IIG)
39569 PHKT(2,IIG)=PHKK(2,KKG)
39570 PG2=PG2+ PHKT(2,IIG)
39571 PHKT(3,IIG)=PHKK(3,KKG)
39572 PG3=PG3+ PHKT(3,IIG)
39573 PHKT(4,IIG)=PHKK(4,KKG)
39574 PG4=PG4+ PHKT(4,IIG)
39575 PHKT(5,IIG)=PHKK(5,KKG)
39576 VHKT(1,IIG) =VHKK(1,KKG)
39577 VHKT(2,IIG) =VHKK(2,KKG)
39578 VHKT(3,IIG) =VHKK(3,KKG)
39579 VHKT(4,IIG) =VHKK(4,KKG)
39580 WHKT(1,IIG) =WHKK(1,KKG)
39581 WHKT(2,IIG) =WHKK(2,KKG)
39582 WHKT(3,IIG) =WHKK(3,KKG)
39583 WHKT(4,IIG) =WHKK(4,KKG)
39586 IDHKT(8+IIGLU1+IIGLU2) =IP2
39587 ISTHKT(8+IIGLU1+IIGLU2) =922
39588 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39589 JMOHKT(2,8+IIGLU1+IIGLU2)=0
39590 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39591 JDAHKT(2,8+IIGLU1+IIGLU2)=0
39593 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39594 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39596 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39597 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39598 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39599 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39600 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
39601 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39602 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39603 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39604 IF(XMIST.GT.0.D0)THEN
39605 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39606 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39607 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39609 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39610 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39612 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
39613 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
39614 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
39615 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
39616 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
39617 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
39618 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
39619 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
39620 IDHKT(9+IIGLU1+IIGLU2) =88888
39621 C IDHKT(9) =1000*NNNC2+MMMC2+10
39622 ISTHKT(9+IIGLU1+IIGLU2) =93
39624 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39625 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39626 JDAHKT(1,9+IIGLU1+IIGLU2)=0
39627 JDAHKT(2,9+IIGLU1+IIGLU2)=0
39628 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
39629 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39630 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
39631 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39632 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
39633 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39634 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
39635 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39636 PHKT(5,9+IIGLU1+IIGLU2)
39637 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39638 * PHKT(2,9+IIGLU1+IIGLU2)**2
39639 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
39641 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39642 * JMOHKT(1,7+IIGLU1),
39643 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39644 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39645 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39646 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39647 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39649 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39651 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39652 * IDHKT(8+IIGLU1+IIGLU2),
39653 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39654 * JDAHKT(1,8+IIGLU1+IIGLU2),
39655 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39656 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39657 * IDHKT(9+IIGLU1+IIGLU2),
39658 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39659 * JDAHKT(1,9+IIGLU1+IIGLU2),
39660 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39664 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39665 ELSEIF(IPIP.EQ.2)THEN
39666 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39668 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39672 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
39673 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39676 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
39677 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
39678 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
39679 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
39680 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
39681 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
39682 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
39683 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
39685 IGCOUN=9+IIGLU1+IIGLU2
39690 *$ CREATE HKKHKT.FOR
39693 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39695 SUBROUTINE HKKHKT(I,J)
39696 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39700 PARAMETER (NMXHKK=200000)
39701 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39702 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39703 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39704 * extended event history
39705 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39706 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39709 PARAMETER (NTMHKK= 300)
39710 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39711 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39714 ISTHKK(I) =ISTHKT(J)
39716 C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39717 IF(IDHKK(I).EQ.88888)THEN
39720 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39721 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39723 JMOHKK(1,I)=JMOHKT(1,J)
39724 JMOHKK(2,I)=JMOHKT(2,J)
39726 JDAHKK(1,I)=JDAHKT(1,J)
39727 JDAHKK(2,I)=JDAHKT(2,J)
39728 C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39730 C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39733 IF(JDAHKT(1,J).GT.0)THEN
39734 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39736 PHKK(1,I) =PHKT(1,J)
39737 PHKK(2,I) =PHKT(2,J)
39738 PHKK(3,I) =PHKT(3,J)
39739 PHKK(4,I) =PHKT(4,J)
39740 PHKK(5,I) =PHKT(5,J)
39741 VHKK(1,I) =VHKT(1,J)
39742 VHKK(2,I) =VHKT(2,J)
39743 VHKK(3,I) =VHKT(3,J)
39744 VHKK(4,I) =VHKT(4,J)
39745 WHKK(1,I) =WHKT(1,J)
39746 WHKK(2,I) =WHKT(2,J)
39747 WHKK(3,I) =WHKT(3,J)
39748 WHKK(4,I) =WHKT(4,J)
39752 *$ CREATE DT_DBREAK.FOR
39755 *===dbreak=============================================================*
39757 SUBROUTINE DT_DBREAK(MODE)
39759 ************************************************************************
39760 * This is the steering subroutine for the different diquark breaking *
39763 * MODE = 1 breaking of projectile diquark in qq-q chain using *
39764 * a sea quark (q-qq chain) of the same projectile *
39765 * = 2 breaking of target diquark in q-qq chain using *
39766 * a sea quark (qq-q chain) of the same target *
39767 * = 3 breaking of projectile diquark in qq-q chain using *
39768 * a sea quark (q-aq chain) of the same projectile *
39769 * = 4 breaking of target diquark in q-qq chain using *
39770 * a sea quark (aq-q chain) of the same target *
39771 * = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
39772 * a sea anti-quark (aq-aqaq chain) of the same projectile *
39773 * = 6 breaking of target anti-diquark in aq-aqaq chain using *
39774 * a sea anti-quark (aqaq-aq chain) of the same target *
39775 * = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
39776 * a sea anti-quark (aq-q chain) of the same projectile *
39777 * = 8 breaking of target anti-diquark in aq-aqaq chain using *
39778 * a sea anti-quark (q-aq chain) of the same target *
39780 * Original version by J. Ranft. *
39781 * This version dated 17.5.00 is written by S. Roesler. *
39782 ************************************************************************
39784 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39786 PARAMETER ( LINP = 10 ,
39791 PARAMETER (NMXHKK=200000)
39792 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39793 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39794 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39795 * extended event history
39796 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39797 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39799 * flags for input different options
39800 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39801 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39802 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39803 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39804 PARAMETER (MAXCHN=10000)
39805 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39806 * diquark-breaking mechanism
39807 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39808 * flags for particle decays
39809 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39810 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39811 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39814 * chain identifiers
39815 * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
39816 * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39817 DIMENSION IDCHN1(8),IDCHN2(8)
39818 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39819 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39821 * parton identifiers
39822 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39823 * +-51/52 = unitarity-sea, +-61/62 = gluons )
39824 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39825 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39826 & 31, 31, 31, 31, 31, 31, 31, 31,
39827 & 41, 41, 41, 41, 51, 51, 51, 51/
39828 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39829 & 32, 32, 32, 32, 32, 32, 32, 32,
39830 & 42, 42, 42, 42, 52, 52, 52, 52/
39831 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39832 & 51, 31, 41, 41, 31, 31, 31, 31,
39833 & 0, 41, 51, 51, 51, 51, 51, 51/
39834 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39835 & 32, 52, 42, 42, 32, 32, 32, 32,
39836 & 42, 0, 52, 52, 52, 52, 52, 52/
39838 IF (NCHAIN.LE.0) RETURN
39841 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39842 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39843 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39845 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39846 & (IS1P.EQ.ISP1P(MODE,3)))
39848 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39849 & (IS1T.EQ.ISP1T(MODE,3)))
39853 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39854 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39855 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39857 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39858 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
39860 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39861 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
39863 * find mother nucleons of the diquark to be splitted and of the
39864 * sea-quark and reject this combination if it is not the same
39865 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39866 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39871 IDXMO1 = JMOHKK(IANCES,IDX1)
39873 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39874 & (JMOHKK(2,IDXMO1).NE.0)) THEN
39879 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39880 IDXMO1 = JMOHKK(IANC,IDXMO1)
39883 IDXMO2 = JMOHKK(IANCES,IDX2)
39885 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39886 & (JMOHKK(2,IDXMO2).NE.0)) THEN
39891 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39892 IDXMO2 = JMOHKK(IANC,IDXMO2)
39895 IF (IDXMO1.NE.IDXMO2) GOTO 2
39896 * quark content of projectile parton
39897 IP1 = IDHKK(JMOHKK(1,IDX1))
39899 IP12 = (IP1-1000*IP11)/100
39900 IP2 = IDHKK(JMOHKK(2,IDX1))
39902 IP22 = (IP2-1000*IP21)/100
39903 * quark content of target parton
39904 IT1 = IDHKK(JMOHKK(1,IDX2))
39906 IT12 = (IT1-1000*IT11)/100
39907 IT2 = IDHKK(JMOHKK(2,IDX2))
39909 IT22 = (IT2-1000*IT21)/100
39910 * split diquark and form new chains
39911 IF (MODE.EQ.1) THEN
39912 IF (IT1.EQ.4) GOTO 2
39913 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39914 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39915 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39916 ELSEIF (MODE.EQ.2) THEN
39917 IF (IT2.EQ.4) GOTO 2
39918 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39919 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39920 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39921 ELSEIF (MODE.EQ.3) THEN
39922 IF (IT1.EQ.4) GOTO 2
39923 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39924 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39925 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39926 ELSEIF (MODE.EQ.4) THEN
39927 IF (IT2.EQ.4) GOTO 2
39928 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39929 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39930 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39931 ELSEIF (MODE.EQ.5) THEN
39932 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39933 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39934 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39935 ELSEIF (MODE.EQ.6) THEN
39936 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39937 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39938 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39939 ELSEIF (MODE.EQ.7) THEN
39940 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39941 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39942 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39943 ELSEIF (MODE.EQ.8) THEN
39944 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39945 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39946 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
39948 IF (IREJ.GE.1) THEN
39949 if ((ipq.lt.0).or.(ipq.ge.4))
39950 & write(LOUT,*) 'ipq !!!',ipq,mode
39951 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39952 * accept or reject new chains corresponding to PDBSEA
39954 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
39955 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
39956 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
39957 ELSEIF (IPQ.EQ.3) THEN
39958 ACC = DBRKA(3,MODE)
39959 REJ = DBRKR(3,MODE)
39961 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
39964 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
39965 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
39968 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39971 * new chains have been accepted and are now copied into HKKEVT
39972 IF (IACC.EQ.1) THEN
39974 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
39975 & PHKK(3,IDX1),PHKK(4,IDX1),
39977 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
39978 & PHKK(3,IDX2),PHKK(4,IDX2),
39981 IDHKK(IDX1) = 99888
39982 IDHKK(IDX2) = 99888
39987 CALL HKKHKT(NHKK,K)
39988 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
39993 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
39998 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
40000 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40012 *$ CREATE DT_CQPAIR.FOR
40015 *===cqpair=============================================================*
40017 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40019 ************************************************************************
40020 * This subroutine Creates a Quark-antiquark PAIR from the sea. *
40022 * XQMAX maxium energy fraction of quark (input) *
40023 * XAQMAX maxium energy fraction of antiquark (input) *
40024 * XQ energy fraction of quark (output) *
40025 * XAQ energy fraction of antiquark (output) *
40026 * IFLV quark flavour (- antiquark flavor) (output) *
40028 * This version dated 14.5.00 is written by S. Roesler. *
40029 ************************************************************************
40031 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40033 PARAMETER ( LINP = 10 ,
40037 * Lorentz-parameters of the current interaction
40038 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40039 & UMO,PPCM,EPROJ,PPROJ
40046 * sample quark flavour
40048 * set seasq here (the one from DTCHAI should be used in the future)
40050 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40052 * sample energy fractions of sea pair
40053 * we first sample the energy fraction of a gluon and then split the gluon
40055 * maximum energy fraction of the gluon forced via input
40056 XGMAXI = XQMAX+XAQMAX
40057 * minimum energy fraction of the gluon
40058 XTHR1 = 4.0D0 /UMO**2
40059 XTHR2 = 0.54D0/UMO**1.5D0
40060 XGMIN = MAX(XTHR1,XTHR2)
40061 * maximum energy fraction of the gluon
40063 XGMAX = MIN(XGMAXI,XGMAX)
40064 IF (XGMIN.GE.XGMAX) THEN
40069 * sample energy fraction of the gluon
40073 IF (NLOOP.GE.50) THEN
40077 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40078 EGLUON = XGLUON*UMO/2.0D0
40080 * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40081 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40084 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40086 IF (RQ.LT.0.5D0) THEN
40093 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1