2 * +-------------------------------------------------------------+
8 * | S. Roesler+), R. Engel#), J. Ranft*) |
11 * | CH-1211 Geneva 23, Switzerland |
12 * | Email: Stefan.Roesler@cern.ch |
14 * | #) University of Delaware, BRI |
15 * | Newark, DE 19716, USA |
17 * | *) University of Siegen, Dept. of Physics |
18 * | D-57068 Siegen, Germany |
21 * | http://home.cern.ch/sroesler/dpmjet3.html |
24 * | Monte Carlo models used for event generation: |
25 * | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 |
27 * +-------------------------------------------------------------+
30 *===init===============================================================*
33 SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
36 ************************************************************************
37 * Initialization of event generation *
38 * This version dated 7.4.98 is written by S. Roesler. *
39 ************************************************************************
41 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
44 PARAMETER ( LINP = 5 ,
48 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
50 * particle properties (BAMJET index convention)
52 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
53 & IICH(210),IIBAR(210),K1(210),K2(210)
54 * names of hadrons used in input-cards
56 COMMON /DTPAIN/ BTYPE(30)
58 INCLUDE './flukapro/(DIMPAR)'
59 INCLUDE './flukapro/(PAREVT)'
60 INCLUDE './flukapro/(EVAPAR)'
61 INCLUDE './flukapro/(FRBKCM)'
63 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
66 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
68 * Glauber formalism: parameters
69 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
70 & BMAX(NCOMPX),BSTEP(NCOMPX),
71 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
73 * Glauber formalism: cross sections
74 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
75 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
76 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
77 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
78 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
79 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
80 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
81 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
82 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
83 & BSLOPE,NEBINI,NQBINI
84 * interface HADRIN-DPM
85 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
86 * central particle production, impact parameter biasing
87 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
88 * parameter for intranuclear cascade
90 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
91 * various options for treatment of partons (DTUNUC 1.x)
92 * (chain recombination, Cronin,..)
94 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
96 * threshold values for x-sampling (DTUNUC 1.x)
97 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
99 * flags for input different options
100 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
101 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
102 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
105 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
106 & EBINDP(2),EBINDN(2),EPOT(2,210),
107 & ETACOU(2),ICOUL,LFERMI
108 * n-n cross section fluctuations
109 PARAMETER (NBINS = 1000)
110 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
111 * flags for particle decays
112 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
113 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
114 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
115 * diquark-breaking mechanism
116 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
117 * nucleon-nucleon event-generator
120 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
121 * properties of interacting particles
122 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
123 * properties of photon/lepton projectiles
124 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
125 * flags for diffractive interactions (DTUNUC 1.x)
126 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
127 * parameters for hA-diffraction
128 COMMON /DTDIHA/ DIBETA,DIALPH
129 * Lorentz-parameters of the current interaction
130 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
131 & UMO,PPCM,EPROJ,PPROJ
132 * kinematical cuts for lepton-nucleus interactions
133 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
134 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
135 * VDM parameter for photon-nucleus interactions
136 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
137 * Glauber formalism: flags and parameters for statistics
140 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
141 * cuts for variable energy runs
142 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
143 * flags for activated histograms
144 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
146 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
148 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
151 **LUND single / double precision
152 REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
153 COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
154 & TMPX,TMPY,TMPW2,TMPQ2,TMPU
157 COMMON /LEPTOI/ RPPN,LEPIN,INTER
158 * steering flags for qel neutrino scattering modules
159 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
161 COMMON /DTEVNO/ NEVENT,ICASCA
166 DIMENSION XDUMB(40),IPRANG(5)
168 PARAMETER (MXCARD=58)
169 CHARACTER*78 CLINE,CTITLE
171 CHARACTER*8 BLANK,SDUM
172 CHARACTER*10 CODE,CODEWD
174 LOGICAL LSTART,LEINP,LXSTAB
175 DIMENSION WHAT(6),CODE(MXCARD)
177 & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ',
178 & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ',
179 & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ',
180 & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ',
181 & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ',
182 & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ',
183 & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ',
184 & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ',
185 & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ',
186 & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
187 & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ',
188 & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ',
189 & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ',
190 & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
194 DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
197 * --- Added by Chiara
199 CHARACTER*100 ALIROOT
205 *---------------------------------------------------------------------
206 * at the first call of INIT: initialize event generation
210 * initialization and test of the random number generator
211 IF (ITRSPT.NE.1) THEN
213 CALL FL48UT (ISRM48,ISEED1,ISEED2)
214 CALL FL48IN (54217137,ISEED1,ISEED2)
217 * initialization of BAMJET, DECAY and HADRIN
222 * set default values for input variables
223 CALL DT_DEFAUL(EPN,PPN)
226 * flag for collision energy input
231 *---------------------------------------------------------------------
234 * bypass reading input cards (e.g. for use with Fluka)
235 * in this case Epn is expected to carry the beam momentum
236 IF (NCASES.EQ.-1) THEN
250 * read control card from input-unit LINP
251 C READ(LINP,'(A78)',END=9999) CLINE
252 * ### Read control card from specified file
253 * ### Changed by Chiara (original version LINP=5)
255 * + FILE='/home/oppedisa/AliRoot/new/DPMJET/inp/PbPbLHC.inp',
258 CALL GETENVF('ALICE_ROOT',ALIROOT)
259 LNROOT = LNBLNK(ALIROOT)
261 FILNAM=ALIROOT(1:LNROOT)//'/DPMJET/inp/PbPbLHC.inp'
262 OPEN(UNIT=7,FILE=FILNAM,STATUS='OLD')
265 READ(7,'(A78)',END=9999) CLINE
267 IF (CLINE(1:1).EQ.'*') THEN
269 C WRITE(LOUT,'(A78)') CLINE
272 C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
273 C1000 FORMAT(A10,6E10.0,A8)
277 READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
278 1006 FORMAT(A10,A60,A8)
279 READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
281 WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
282 1001 FORMAT(A10,6G10.3,A8)
286 * check for valid control card and get card index
289 IF (CODEWD.EQ.CODE(I)) ICW = I
292 WRITE(LOUT,1002) CODEWD
293 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
298 *------------------------------------------------------------
299 * TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM,
300 & 100 , 110 , 120 , 130 , 140 ,
302 *------------------------------------------------------------
303 * CMENERGY, EMULSION, FERMI , TAUFOR , PAULI ,
304 & 150 , 160 , 170 , 180 , 190 ,
306 *------------------------------------------------------------
307 * COULOMB , HADRIN , EVAP , EMCCHECK, MODEL ,
308 & 200 , 210 , 220 , 230 , 240 ,
310 *------------------------------------------------------------
311 * PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN,
312 & 250 , 260 , 270 , 280 , 290 ,
314 *------------------------------------------------------------
315 * COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR,
316 & 300 , 310 , 320 , 330 , 340 ,
318 *------------------------------------------------------------
319 * SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH,
320 & 350 , 360 , 370 , 380 , 390 ,
322 *------------------------------------------------------------
323 * NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM ,
324 & 400 , 410 , 420 , 430 , 440 ,
326 *------------------------------------------------------------
327 * LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
328 & 450 , 451 , 452 , 460 , 470 ,
330 *------------------------------------------------------------
331 * OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT,
332 & 480 , 490 , 500 , 510 , 520 ,
334 *------------------------------------------------------------
335 * VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
336 & 530 , 540 , 550 , 560 , 565 ,
338 *------------------------------------------------------------
339 * , , VDM-PAR2, XS-QELPRO, RNDMINIT ,
342 *------------------------------------------------------------
343 * LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP )
344 & 600 , 610 , 620 , 630 , 640 ) , ICW
346 *------------------------------------------------------------
350 *********************************************************************
352 * control card: codewd = TITLE *
354 * what (1..6), sdum no meaning *
356 * Note: The control-card following this must consist of *
357 * a string of characters usually giving the title of *
360 *********************************************************************
363 C READ(LINP,'(A78)') CTITLE
364 * ### Read control card from specified file
365 * ### Changed by Chiara (original version LINP=5)
366 READ(7,'(A78)') CTITLE
368 WRITE(LOUT,'(//,5X,A78,//)') CTITLE
371 *********************************************************************
373 * control card: codewd = PROJPAR *
375 * what (1) = mass number of projectile nucleus default: 1 *
376 * what (2) = charge of projectile nucleus default: 1 *
377 * what (3..6) no meaning *
378 * sdum projectile particle code word *
380 * Note: If sdum is defined what (1..2) have no meaning. *
382 *********************************************************************
385 IF (SDUM.EQ.BLANK) THEN
393 IF (SDUM.EQ.BTYPE(II)) THEN
398 ELSEIF (II.EQ.27) THEN
400 ELSEIF (II.EQ.28) THEN
402 ELSEIF (II.EQ.29) THEN
407 IBPROJ = IIBAR(IJPROJ)
409 IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
411 IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
412 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
413 & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
416 IF (IJPROJ.EQ.0) THEN
418 1110 FORMAT(/,1X,'invalid PROJPAR card !',/)
424 *********************************************************************
426 * control card: codewd = TARPAR *
428 * what (1) = mass number of target nucleus default: 1 *
429 * what (2) = charge of target nucleus default: 1 *
430 * what (3..6) no meaning *
431 * sdum target particle code word *
433 * Note: If sdum is defined what (1..2) have no meaning. *
435 *********************************************************************
438 IF (SDUM.EQ.BLANK) THEN
446 IF (SDUM.EQ.BTYPE(II)) THEN
450 IBTARG = IIBAR(IJTARG)
453 IF (IJTARG.EQ.0) THEN
455 1120 FORMAT(/,1X,'invalid TARPAR card !',/)
461 *********************************************************************
463 * control card: codewd = ENERGY *
465 * what (1) = energy (GeV) of projectile in Lab. *
466 * if what(1) < 0: |what(1)| = kinetic energy *
468 * if |what(2)| > 0: min. energy for variable *
470 * what (2) = max. energy for variable energy runs *
471 * if what(2) < 0: |what(2)| = kinetic energy *
473 *********************************************************************
479 IF ((ABS(WHAT(2)).GT.ZERO).AND.
480 & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
488 *********************************************************************
490 * control card: codewd = MOMENTUM *
492 * what (1) = momentum (GeV/c) of projectile in Lab. *
493 * default: 200 GeV/c *
494 * what (2..6), sdum no meaning *
496 *********************************************************************
505 *********************************************************************
507 * control card: codewd = CMENERGY *
509 * what (1) = energy in nucleon-nucleon cms. *
511 * what (2..6), sdum no meaning *
513 *********************************************************************
522 *********************************************************************
524 * control card: codewd = EMULSION *
526 * definition of nuclear emulsions *
528 * what(1) mass number of emulsion component *
529 * what(2) charge of emulsion component *
530 * what(3) fraction of events in which a scattering on a *
531 * nucleus of this properties is performed *
532 * what(4,5,6) as what(1,2,3) but for another component *
533 * default: no emulsion *
536 * Note: If this input-card is once used with valid parameters *
537 * TARPAR is obsolete. *
538 * Not the absolute values of the fractions are important *
539 * but only the ratios of fractions of different comp. *
540 * This control card can be repeatedly used to define *
541 * emulsions consisting of up to 10 elements. *
543 *********************************************************************
546 IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
547 & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
549 IF (NCOMPO.GT.NCOMPX) THEN
553 IEMUMA(NCOMPO) = INT(WHAT(1))
554 IEMUCH(NCOMPO) = INT(WHAT(2))
555 EMUFRA(NCOMPO) = WHAT(3)
557 C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
559 IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
560 & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
562 IF (NCOMPO.GT.NCOMPX) THEN
566 IEMUMA(NCOMPO) = INT(WHAT(4))
567 IEMUCH(NCOMPO) = INT(WHAT(5))
568 EMUFRA(NCOMPO) = WHAT(6)
569 C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
571 1600 FORMAT(1X,'too many emulsion components - program stopped')
574 *********************************************************************
576 * control card: codewd = FERMI *
578 * what (1) = -1 Fermi-motion of nucleons not treated *
580 * what (2) = scale factor for Fermi-momentum *
582 * what (3..6), sdum no meaning *
584 *********************************************************************
587 IF (WHAT(1).EQ.-1.0D0) THEN
593 IF (XMOD.GE.ZERO) FERMOD = XMOD
596 *********************************************************************
598 * control card: codewd = TAUFOR *
600 * formation time supressed intranuclear cascade *
602 * what (1) formation time (in fm/c) *
603 * note: what(1)=10. corresponds roughly to an *
604 * average formation time of 1 fm/c *
606 * what (2) number of generations followed *
608 * what (3) = 1. p_t-dependent formation zone *
609 * = 2. constant formation zone *
611 * what (4) modus of selection of nucleus where the *
612 * cascade if followed first *
613 * = 1. proj./target-nucleus with probab. 1/2 *
614 * = 2. nucleus with highest mass *
615 * = 3. proj. nucleus if particle is moving in pos. z *
616 * targ. nucleus if particle is moving in neg. z *
618 * what (5..6), sdum no meaning *
620 *********************************************************************
624 KTAUGE = INT(WHAT(2))
626 IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
627 & ITAUVE = INT(WHAT(3))
628 IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
629 & INCMOD = INT(WHAT(4))
632 *********************************************************************
634 * control card: codewd = PAULI *
636 * what (1) = -1 Pauli's principle for secondary *
637 * interactions not treated *
639 * what (2..6), sdum no meaning *
641 *********************************************************************
644 IF (WHAT(1).EQ.-1.0D0) THEN
651 *********************************************************************
653 * control card: codewd = COULOMB *
655 * what (1) = -1. Coulomb-energy treatment switched off *
657 * what (2..6), sdum no meaning *
659 *********************************************************************
663 IF (WHAT(1).EQ.-1.0D0) THEN
670 *********************************************************************
672 * control card: codewd = HADRIN *
676 * what (1) = 0. elastic/inelastic interactions with probab. *
677 * as defined by cross-sections *
678 * = 1. inelastic interactions forced *
679 * = 2. elastic interactions forced *
681 * what (2) upper threshold in total energy (GeV) below *
682 * which interactions are sampled by HADRIN *
684 * what (3..6), sdum no meaning *
686 *********************************************************************
690 IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
691 IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
694 *********************************************************************
696 * control card: codewd = EVAP *
698 * evaporation module *
700 * what (1) =< -1 ==> evaporation is switched off *
701 * >= 1 ==> evaporation is performed *
703 * what (1) = i1 + i2*10 + i3*100 + i4*10000 *
704 * (i1, i2, i3, i4 >= 0 ) *
706 * i1 is the flag for selecting the T=0 level density option used *
707 * = 1: standard EVAP level densities with Cook pairing *
709 * = 2: Z,N-dependent Gilbert & Cameron level densities *
711 * = 3: Julich A-dependent level densities *
712 * = 4: Z,N-dependent Brancazio & Cameron level densities *
714 * i2 >= 1: high energy fission activated *
715 * (default high energy fission activated) *
717 * i3 = 0: No energy dependence for level densities *
718 * = 1: Standard Ignyatuk (1975, 1st) energy dependence *
719 * for level densities (default) *
720 * = 2: Standard Ignyatuk (1975, 1st) energy dependence *
721 * for level densities with NOT used set of parameters *
722 * = 3: Standard Ignyatuk (1975, 1st) energy dependence *
723 * for level densities with NOT used set of parameters *
724 * = 4: Second Ignyatuk (1975, 2nd) energy dependence *
725 * for level densities *
726 * = 5: Second Ignyatuk (1975, 2nd) energy dependence *
727 * for level densities with fit 1 Iljinov & Mebel set of *
729 * = 6: Second Ignyatuk (1975, 2nd) energy dependence *
730 * for level densities with fit 2 Iljinov & Mebel set of *
732 * = 7: Second Ignyatuk (1975, 2nd) energy dependence *
733 * for level densities with fit 3 Iljinov & Mebel set of *
735 * = 8: Second Ignyatuk (1975, 2nd) energy dependence *
736 * for level densities with fit 4 Iljinov & Mebel set of *
739 * i4 >= 1: Original Gilbert and Cameron pairing energies used *
740 * (default Cook's modified pairing energies) *
742 * what (2) = ig + 10 * if (ig and if must have the same sign) *
744 * ig =< -1 ==> deexcitation gammas are not produced *
745 * (if the evaporation step is not performed *
746 * they are never produced) *
747 * if =< -1 ==> Fermi Break Up is not invoked *
748 * (if the evaporation step is not performed *
749 * it is never invoked) *
750 * The default is: deexcitation gamma produced and Fermi break up *
751 * activated for the new preequilibrium, not *
752 * activated otherwise. *
753 * what (3..6), sdum no meaning *
755 *********************************************************************
759 IF (WHAT(1).LE.-1.0D0) THEN
766 IF ( NINT (WHAT (1)) .GE. 10000 ) THEN
768 JLVHLP = NINT (WHAT (1)) / 10000
769 WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP
771 IF ( NINT (WHAT (1)) .GE. 100 ) THEN
772 JLVMOD = NINT (WHAT (1)) / 100
773 WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD
775 IF ( NINT (WHAT (1)) .GE. 10 ) THEN
777 JLVHLP = NINT (WHAT (1)) / 10
778 WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP
779 ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN
782 IF ( NINT (WHAT (1)) .GE. 0 ) THEN
784 ILVMOD = NINT (WHAT(1))
785 IF ( ABS (NINT (WHAT (2))) .GE. 10 ) THEN
787 JLVHLP = NINT (WHAT (2)) / 10
788 WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP
789 ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN
792 IF ( NINT (WHAT (2)) .GE. 0 ) THEN
797 **sr heavies are always put to /FKFHVY/
798 C IF ( NINT (WHAT(3)) .GE. 1 ) THEN
814 *********************************************************************
816 * control card: codewd = EMCCHECK *
818 * extended energy-momentum / quantum-number conservation check *
820 * what (1) = -1 extended check not performed *
822 * what (2..6), sdum no meaning *
824 *********************************************************************
827 IF (WHAT(1).EQ.-1) THEN
834 *********************************************************************
836 * control card: codewd = MODEL *
838 * Model to be used to treat nucleon-nucleon interactions *
840 * sdum = DTUNUC two-chain model *
841 * = PHOJET multiple chains including minijets *
843 * = QNEUTRIN quasi-elastic neutrino scattering *
847 * what (1) (variable INTER) *
848 * = 1 gamma exchange *
851 * = 4 gamma/Z0 exchange *
853 * if sdum = QNEUTRIN: *
854 * what (1) = 0 elastic scattering on nucleon and *
855 * tau does not decay (default) *
856 * = 1 decay of tau into mu.. *
857 * = 2 decay of tau into e.. *
858 * = 10 CC events on p and n *
859 * = 11 NC events on p and n *
861 * what (2..6) no meaning *
863 *********************************************************************
866 IF (SDUM.EQ.CMODEL(1)) THEN
868 ELSEIF (SDUM.EQ.CMODEL(2)) THEN
870 ELSEIF (SDUM.EQ.CMODEL(3)) THEN
872 IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
873 & INTER = INT(WHAT(1))
874 ELSEIF (SDUM.EQ.CMODEL(4)) THEN
877 IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
878 & (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
881 STOP ' Unknown model !'
885 *********************************************************************
887 * control card: codewd = PHOINPUT *
889 * Start of input-section for PHOJET-specific input-cards *
890 * Note: This section will not be finished before giving *
892 * what (1..6), sdum no meaning *
894 *********************************************************************
899 C CALL PHO_INIT(LINP,IREJ1)
900 * ### Read control card from specified file
901 * ### Changed by Chiara (original version LINP=5)
902 CALL PHO_INIT(7,IREJ1)
905 WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed'
912 *********************************************************************
914 * control card: codewd = GLAUBERI *
916 * Pre-initialization of impact parameter selection *
918 * what (1..6), sdum no meaning *
920 *********************************************************************
923 IF (IFIRST.NE.99) THEN
924 CALL DT_RNDMST(12,34,56,78)
926 OPEN(40,FILE='shm.out',STATUS='UNKNOWN')
927 C OPEN(11,FILE='shm.dbg',STATUS='UNKNOWN')
938 ADP = (APHI-APLOW)/DBLE(IPPN)
959 IT = ITLOW+(NCIT-1)*IDIT
962 C IIP = (IPHI-IPLOW)/IDIP
963 C IF (IIP.EQ.0) IIP = 1
964 C IF (IT.EQ.IPLOW) IIP = 0
968 CC IF (NCIP.LE.IIP) THEN
969 C IP = IPLOW+(NCIP-1)*IDIP
973 IF (IP.GT.IT) GOTO 472
976 APPN = APLOW+DBLE(NCP-1)*ADP
979 OPEN(12,FILE='shm.sta',STATUS='UNKNOWN')
980 WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
987 CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
988 CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
991 C IF ((IP.GT.10).OR.(IT.GT.10)) THEN
999 CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
1000 SIGAV = SIGAV+XSPRO(1,1,1)
1003 CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
1007 CALL DT_EVTHIS(IDUM)
1009 C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
1011 C CALL GENFIT(XPARA)
1012 C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
1013 C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
1023 *********************************************************************
1025 * control card: codewd = FLUCTUAT *
1027 * Treatment of cross section fluctuations *
1029 * what (1) = 1 treat cross section fluctuations *
1031 * what (1..6), sdum no meaning *
1033 *********************************************************************
1037 IF (WHAT(1).EQ.ONE) THEN
1043 *********************************************************************
1045 * control card: codewd = CENTRAL *
1047 * what (1) = 1. central production forced default: 0 *
1048 * if what (1) < 0 and > -100 *
1049 * what (2) = min. impact parameter default: 0 *
1050 * what (3) = max. impact parameter default: b_max *
1051 * if what (1) < -99 *
1052 * what (2) = fraction of cross section default: 1 *
1053 * if what (1) = -1 : evaporation/fzc suppressed *
1054 * if what (1) < -1 : evaporation/fzc allowed *
1056 * what (4..6), sdum no meaning *
1058 *********************************************************************
1061 ICENTR = INT(WHAT(1))
1062 IF (ICENTR.LT.0) THEN
1063 IF (ICENTR.GT.-100) THEN
1072 *********************************************************************
1074 * control card: codewd = RECOMBIN *
1076 * Chain recombination *
1077 * (recombine S-S and V-V chains to V-S chains) *
1079 * what (1) = -1. recombination switched off default: 1 *
1080 * what (2..6), sdum no meaning *
1082 *********************************************************************
1086 IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1089 *********************************************************************
1091 * control card: codewd = COMBIJET *
1093 * chain fusion (2 q-aq --> qq-aqaq) *
1095 * what (1) = 1 fusion treated *
1097 * what (2) minimum number of uncombined chains from *
1098 * single projectile or target nucleons *
1100 * what (3..6), sdum no meaning *
1102 *********************************************************************
1106 IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1107 IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1110 *********************************************************************
1112 * control card: codewd = XCUTS *
1114 * thresholds for x-sampling *
1116 * what (1) defines lower threshold for val.-q x-value (CVQ) *
1118 * what (2) defines lower threshold for val.-qq x-value (CDQ) *
1120 * what (3) defines lower threshold for sea-q x-value (CSEA) *
1122 * what (4) sea-q x-values in S-S chains (SSMIMA) *
1124 * what (5) not used *
1126 * what (6), sdum no meaning *
1128 * Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1130 *********************************************************************
1133 IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1)
1134 IF (WHAT(2).GE.ONE) CDQ = WHAT(2)
1135 IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3)
1136 IF (WHAT(4).GE.ZERO) THEN
1140 IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1143 *********************************************************************
1145 * control card: codewd = INTPT *
1147 * what (1) = -1 intrinsic transverse momenta of partons *
1148 * not treated default: 1 *
1149 * what (2..6), sdum no meaning *
1151 *********************************************************************
1154 IF (WHAT(1).EQ.-1.0D0) THEN
1161 *********************************************************************
1163 * control card: codewd = CRONINPT *
1165 * Cronin effect (multiple scattering of partons at chain ends) *
1167 * what (1) = -1 Cronin effect not treated default: 1 *
1168 * what (2) = 0 scattering parameter default: 0.64 *
1169 * what (3..6), sdum no meaning *
1171 *********************************************************************
1174 IF (WHAT(1).EQ.-1.0D0) THEN
1182 *********************************************************************
1184 * control card: codewd = SEADISTR *
1186 * what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. *
1187 * what (2) (UNON) default: 2. *
1188 * what (3) (UNOM) default: 1.5 *
1189 * what (4) (UNOSEA) default: 5. *
1190 * qdis(x) prop. (1-x)**what (1) etc. *
1191 * what (5..6), sdum no meaning *
1193 *********************************************************************
1197 XSEACU = 1.05D0-XSEACO
1199 IF (UNON.LT.0.1D0) UNON = 2.0D0
1201 IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1203 IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1206 *********************************************************************
1208 * control card: codewd = SEASU3 *
1210 * Treatment of strange-quarks at chain ends *
1212 * what (1) (SEASQ) strange-quark supression factor *
1213 * iflav = 1.+rndm*(2.+SEASQ) *
1215 * what (2..6), sdum no meaning *
1217 *********************************************************************
1223 *********************************************************************
1225 * control card: codewd = DIQUARKS *
1227 * what (1) = -1. sea-diquark/antidiquark-pairs not treated *
1229 * what (2..6), sdum no meaning *
1231 *********************************************************************
1234 IF (WHAT(1).EQ.-1.0D0) THEN
1241 *********************************************************************
1243 * control card: codewd = RESONANC *
1245 * treatment of low mass chains *
1247 * what (1) = -1 low chain masses are not corrected for resonance *
1248 * masses (obsolete for BAMJET-fragmentation) *
1250 * what (2) = -1 massless partons default: 1. (massive) *
1251 * default: 1. (massive) *
1252 * what (3) = -1 chain-system containing chain of too small *
1253 * mass is rejected (note: this does not fully *
1254 * apply to S-S chains) default: 0. *
1255 * what (4..6), sdum no meaning *
1257 *********************************************************************
1263 IF (WHAT(1).EQ.-ONE) IRESCO = 0
1264 IF (WHAT(2).EQ.-ONE) IMSHL = 0
1265 IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1268 *********************************************************************
1270 * control card: codewd = DIFFRACT *
1272 * Treatment of diffractive events *
1274 * what (1) = (ISINGD) 0 no single diffraction *
1275 * 1 single diffraction included *
1276 * +-2 single diffractive events only *
1277 * +-3 projectile single diffraction only *
1278 * +-4 target single diffraction only *
1279 * -5 double pomeron exchange only *
1280 * (neg. sign applies to PHOJET events) *
1283 * what (2) = (IDOUBD) 0 no double diffraction *
1284 * 1 double diffraction included *
1285 * 2 double diffractive events only *
1287 * what (3) = 1 projectile diffraction treated (2-channel form.) *
1289 * what (4) = alpha-parameter in projectile diffraction *
1291 * what (5..6), sdum no meaning *
1293 *********************************************************************
1296 IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1297 IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1298 IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1300 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/,
1301 & 11X,'IDOUBD is reset to zero')
1304 IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1305 IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1308 *********************************************************************
1310 * control card: codewd = SINGLECH *
1312 * what (1) = 1. Regge contribution (one chain) included *
1314 * what (2..6), sdum no meaning *
1316 *********************************************************************
1320 IF (WHAT(1).EQ.ONE) ISICHA = 1
1323 *********************************************************************
1325 * control card: codewd = NOFRAGME *
1327 * biased chain hadronization *
1329 * what (1..6) = -1 no of hadronizsation of S-S chains *
1330 * = -2 no of hadronizsation of D-S chains *
1331 * = -3 no of hadronizsation of S-D chains *
1332 * = -4 no of hadronizsation of S-V chains *
1333 * = -5 no of hadronizsation of D-V chains *
1334 * = -6 no of hadronizsation of V-S chains *
1335 * = -7 no of hadronizsation of V-D chains *
1336 * = -8 no of hadronizsation of V-V chains *
1337 * = -9 no of hadronizsation of comb. chains *
1338 * default: complete hadronization *
1341 *********************************************************************
1345 ICHAIN = INT(WHAT(I))
1346 IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1347 & LHADRO(ABS(ICHAIN)) = .FALSE.
1351 *********************************************************************
1353 * control card: codewd = HADRONIZE *
1355 * hadronization model and parameter switch *
1357 * what (1) = 1 hadronization via BAMJET *
1358 * = 2 hadronization via JETSET *
1360 * what (2) = 1..3 parameter set to be used *
1361 * JETSET: 3 sets available *
1362 * ( = 3 default JETSET-parameters) *
1363 * BAMJET: 1 set available *
1365 * what (3..6), sdum no meaning *
1367 *********************************************************************
1370 IWHAT1 = INT(WHAT(1))
1371 IWHAT2 = INT(WHAT(2))
1372 IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1373 IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1377 *********************************************************************
1379 * control card: codewd = POPCORN *
1381 * "Popcorn-effect" in fragmentation and diquark breaking diagrams *
1383 * what (1) = (PDB) frac. of diquark fragmenting directly into *
1384 * baryons (PYTHIA/JETSET fragmentation) *
1385 * (JETSET: = 0. Popcorn mechanism switched off) *
1387 * what (2) = probability for accepting a diquark breaking *
1388 * diagram involving the generation of a u/d quark- *
1389 * antiquark pair default: 0.0 *
1390 * what (3) = same a what (2), here for s quark-antiquark pair *
1392 * what (4..6), sdum no meaning *
1394 *********************************************************************
1397 IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1398 IF (WHAT(2).GE.0.0D0) THEN
1402 IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1404 DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1405 DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1406 DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1410 *********************************************************************
1412 * control card: codewd = PARDECAY *
1414 * what (1) = 1. Sigma0/Asigma0 are decaying within JETSET *
1415 * = 2. pion^0 decay after intranucl. cascade *
1416 * default: no decay *
1417 * what (2..6), sdum no meaning *
1419 *********************************************************************
1422 IF (WHAT(1).EQ.ONE) ISIG0 = 1
1423 IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1426 *********************************************************************
1428 * control card: codewd = BEAM *
1430 * definition of beam parameters *
1432 * what (1/2) > 0 : energy of beam 1/2 (GeV) *
1433 * < 0 : abs(what(1/2)) energy per charge of *
1435 * (beam 1 is directed into positive z-direction) *
1436 * what (3) beam crossing angle, defined as 2x angle between *
1437 * one beam and the z-axis (micro rad) *
1438 * what (4) angle with x-axis defining the collision plane *
1439 * what (5..6), sdum no meaning *
1441 * Note: this card requires previously defined projectile and *
1442 * target identities (PROJPAR, TARPAR) *
1444 *********************************************************************
1447 CALL DT_BEAMPR(WHAT,PPN,1)
1453 *********************************************************************
1455 * control card: codewd = LUND-MSTU *
1457 * set parameter MSTU in JETSET-common /LUDAT1/ *
1459 * what (1) = index according to LUND-common block *
1460 * what (2) = new value of MSTU( int(what(1)) ) *
1461 * what (3), what(4) and what (5), what(6) further *
1462 * parameter in the same way as what (1) and *
1464 * default: default-Lund or corresponding to *
1465 * the set given in HADRONIZE *
1467 *********************************************************************
1470 IF (WHAT(1).GT.ZERO) THEN
1472 IMSTU(NMSTU) = INT(WHAT(1))
1473 MSTUX(NMSTU) = INT(WHAT(2))
1475 IF (WHAT(3).GT.ZERO) THEN
1477 IMSTU(NMSTU) = INT(WHAT(3))
1478 MSTUX(NMSTU) = INT(WHAT(4))
1480 IF (WHAT(5).GT.ZERO) THEN
1482 IMSTU(NMSTU) = INT(WHAT(5))
1483 MSTUX(NMSTU) = INT(WHAT(6))
1487 *********************************************************************
1489 * control card: codewd = LUND-MSTJ *
1491 * set parameter MSTJ in JETSET-common /LUDAT1/ *
1493 * what (1) = index according to LUND-common block *
1494 * what (2) = new value of MSTJ( int(what(1)) ) *
1495 * what (3), what(4) and what (5), what(6) further *
1496 * parameter in the same way as what (1) and *
1498 * default: default-Lund or corresponding to *
1499 * the set given in HADRONIZE *
1501 *********************************************************************
1504 IF (WHAT(1).GT.ZERO) THEN
1506 IMSTJ(NMSTJ) = INT(WHAT(1))
1507 MSTJX(NMSTJ) = INT(WHAT(2))
1509 IF (WHAT(3).GT.ZERO) THEN
1511 IMSTJ(NMSTJ) = INT(WHAT(3))
1512 MSTJX(NMSTJ) = INT(WHAT(4))
1514 IF (WHAT(5).GT.ZERO) THEN
1516 IMSTJ(NMSTJ) = INT(WHAT(5))
1517 MSTJX(NMSTJ) = INT(WHAT(6))
1521 *********************************************************************
1523 * control card: codewd = LUND-MDCY *
1525 * set parameter MDCY(I,1) for particle decays in JETSET-common *
1528 * what (1-6) = PDG particle index of particle which should *
1530 * default: default-Lund or forced in *
1533 *********************************************************************
1537 IF (WHAT(I).NE.ZERO) THEN
1539 KC = PYCOMP(INT(WHAT(I)))
1546 *********************************************************************
1548 * control card: codewd = LUND-PARJ *
1550 * set parameter PARJ in JETSET-common /LUDAT1/ *
1552 * what (1) = index according to LUND-common block *
1553 * what (2) = new value of PARJ( int(what(1)) ) *
1554 * what (3), what(4) and what (5), what(6) further *
1555 * parameter in the same way as what (1) and *
1557 * default: default-Lund or corresponding to *
1558 * the set given in HADRONIZE *
1560 *********************************************************************
1563 IF (WHAT(1).NE.ZERO) THEN
1565 IPARJ(NPARJ) = INT(WHAT(1))
1566 PARJX(NPARJ) = WHAT(2)
1568 IF (WHAT(3).NE.ZERO) THEN
1570 IPARJ(NPARJ) = INT(WHAT(3))
1571 PARJX(NPARJ) = WHAT(4)
1573 IF (WHAT(5).NE.ZERO) THEN
1575 IPARJ(NPARJ) = INT(WHAT(5))
1576 PARJX(NPARJ) = WHAT(6)
1580 *********************************************************************
1582 * control card: codewd = LUND-PARU *
1584 * set parameter PARJ in JETSET-common /LUDAT1/ *
1586 * what (1) = index according to LUND-common block *
1587 * what (2) = new value of PARU( int(what(1)) ) *
1588 * what (3), what(4) and what (5), what(6) further *
1589 * parameter in the same way as what (1) and *
1591 * default: default-Lund or corresponding to *
1592 * the set given in HADRONIZE *
1594 *********************************************************************
1597 IF (WHAT(1).GT.ZERO) THEN
1599 IPARU(NPARU) = INT(WHAT(1))
1600 PARUX(NPARU) = WHAT(2)
1602 IF (WHAT(3).GT.ZERO) THEN
1604 IPARU(NPARU) = INT(WHAT(3))
1605 PARUX(NPARU) = WHAT(4)
1607 IF (WHAT(5).GT.ZERO) THEN
1609 IPARU(NPARU) = INT(WHAT(5))
1610 PARUX(NPARU) = WHAT(6)
1614 *********************************************************************
1616 * control card: codewd = OUTLEVEL *
1618 * output control switches *
1620 * what (1) = internal rejection informations default: 0 *
1621 * what (2) = energy-momentum conservation check output *
1623 * what (3) = internal warning messages default: 0 *
1624 * what (4..6), sdum not yet used *
1626 *********************************************************************
1630 IOULEV(K) = INT(WHAT(K))
1634 *********************************************************************
1636 * control card: codewd = FRAME *
1638 * frame in which final state is given in DTEVT1 *
1640 * what (1) = 1 target rest frame (laboratory) *
1641 * = 2 nucleon-nucleon cms *
1644 *********************************************************************
1647 KFRAME = INT(WHAT(1))
1648 IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1651 *********************************************************************
1653 * control card: codewd = L-TAG *
1656 * definition of kinematical cuts for radiated photon and *
1657 * outgoing lepton detection in lepton-nucleus interactions *
1659 * what (1) = y_min *
1660 * what (2) = y_max *
1661 * what (3) = Q^2_min *
1662 * what (4) = Q^2_max *
1663 * what (5) = theta_min (Lab) *
1664 * what (6) = theta_max (Lab) *
1665 * default: no cuts *
1668 *********************************************************************
1679 *********************************************************************
1681 * control card: codewd = L-ETAG *
1684 * what (1) = min. outgoing lepton energy (in Lab) *
1685 * what (2) = min. photon energy (in Lab) *
1686 * what (3) = max. photon energy (in Lab) *
1687 * default: no cuts *
1688 * what (2..6), sdum no meaning *
1690 *********************************************************************
1693 ELMIN = MAX(WHAT(1),ZERO)
1694 EGMIN = MAX(WHAT(2),ZERO)
1695 EGMAX = MAX(WHAT(3),ZERO)
1698 *********************************************************************
1700 * control card: codewd = ECMS-CUT *
1702 * what (1) = min. c.m. energy to be sampled *
1703 * what (2) = max. c.m. energy to be sampled *
1704 * what (3) = min x_Bj to be sampled *
1705 * default: no cuts *
1706 * what (3..6), sdum no meaning *
1708 *********************************************************************
1713 IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1714 XBJMIN = MAX(WHAT(3),ZERO)
1717 *********************************************************************
1719 * control card: codewd = VDM-PAR1 *
1721 * parameters in gamma-nucleus cross section calculation *
1723 * what (1) = Lambda^2 default: 2. *
1724 * what (2) lower limit in M^2 integration *
1727 * = 3 (m_phi)^2 default: 1 *
1728 * what (3) upper limit in M^2 integration *
1731 * = 3 s default: 3 *
1732 * what (4) CKMT F_2 structure function *
1734 * = 100 deuteron default: 2212 *
1735 * what (5) calculation of gamma-nucleon xsections *
1736 * = 1 according to CKMT-parametrization of F_2 *
1737 * = 2 integrating SIGVP over M^2 *
1739 * = 4 PHOJET cross sections default: 4 *
1741 * what (6), sdum no meaning *
1743 *********************************************************************
1746 IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1747 IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1748 IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1749 IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1750 IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1753 *********************************************************************
1755 * control card: codewd = HISTOGRAM *
1757 * activate different classes of histograms *
1759 * default: no histograms *
1761 *********************************************************************
1765 IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1766 IHISPP(INT(WHAT(J))-100) = 1
1767 ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1768 IHISXS(INT(ABS(WHAT(J)))-200) = 1
1769 IF (WHAT(J).LT.ZERO) IXSTBL = 1
1774 *********************************************************************
1776 * control card: codewd = XS-TABLE *
1778 * output of cross section table for requested interaction *
1779 * - particle production deactivated ! - *
1781 * what (1) lower energy limit for tabulation *
1783 * < 0 nucleon-nucleon cms *
1784 * what (2) upper energy limit for tabulation *
1786 * < 0 nucleon-nucleon cms *
1787 * what (3) > 0 # of equidistant lin. bins in E *
1788 * < 0 # of equidistant log. bins in E *
1789 * what (4) lower limit of particle virtuality (photons) *
1790 * what (5) upper limit of particle virtuality (photons) *
1791 * what (6) > 0 # of equidistant lin. bins in Q^2 *
1792 * < 0 # of equidistant log. bins in Q^2 *
1794 *********************************************************************
1797 IF (WHAT(1).EQ.99999.0D0) THEN
1798 IRATIO = INT(WHAT(2))
1801 CMENER = ABS(WHAT(2))
1802 IF (.NOT.LXSTAB) THEN
1808 IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1810 IF (WHAT(2).GT.ZERO)
1811 & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1814 C WRITE(LOUT,*) 'CMENER = ',CMENER
1815 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1818 CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1823 *********************************************************************
1825 * control card: codewd = GLAUB-PAR *
1827 * parameters in Glauber-formalism *
1829 * what (1) # of nucleon configurations sampled in integration *
1830 * over nuclear desity default: 1000 *
1831 * what (2) # of bins for integration over impact-parameter and *
1832 * for profile-function calculation default: 49 *
1833 * what (3) = 1 calculation of tot., el. and qel. cross sections *
1835 * what (4) = 1 read pre-calculated impact-parameter distrib. *
1837 * =-1 dump pre-calculated impact-parameter distrib. *
1839 * = 100 read pre-calculated impact-parameter distrib. *
1840 * for variable projectile/target/energy runs *
1843 * what (5..6) no meaning *
1844 * sdum if |what (4)| = 1 name of in/output-file (sdum.glb) *
1846 *********************************************************************
1849 IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1850 IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1851 IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1852 IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1853 IOGLB = INT(WHAT(4))
1858 *********************************************************************
1860 * control card: codewd = GLAUB-INI *
1862 * pre-initialization of profile function *
1864 * what (1) lower energy limit for initialization *
1866 * < 0 nucleon-nucleon cms *
1867 * what (2) upper energy limit for initialization *
1869 * < 0 nucleon-nucleon cms *
1870 * what (3) > 0 # of equidistant lin. bins in E *
1871 * < 0 # of equidistant log. bins in E *
1872 * what (4) maximum projectile mass number for which the *
1873 * Glauber data are initialized for each *
1874 * projectile mass number *
1875 * (if <= mass given with the PROJPAR-card) *
1877 * what (5) steps in mass number starting from what (4) *
1878 * up to mass number defined with PROJPAR-card *
1879 * for which Glauber data are initialized *
1881 * what (6) no meaning *
1884 *********************************************************************
1888 CALL DT_GLBINI(WHAT)
1891 *********************************************************************
1893 * control card: codewd = VDM-PAR2 *
1895 * parameters in gamma-nucleus cross section calculation *
1897 * what (1) = 0 no suppression of shadowing by direct photon *
1899 * = 1 suppression .. default: 1 *
1900 * what (2) = 0 no suppression of shadowing by anomalous *
1901 * component if photon-F_2 *
1902 * = 1 suppression .. default: 1 *
1903 * what (3) = 0 no suppression of shadowing by coherence *
1904 * length of the photon *
1905 * = 1 suppression .. default: 1 *
1906 * what (4) = 1 longitudinal polarized photons are taken into *
1908 * eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 *
1909 * what (5..6), sdum no meaning *
1911 *********************************************************************
1914 IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
1915 IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
1916 IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
1920 *********************************************************************
1922 * control card: XS-QELPRO *
1924 * what (1..6), sdum no meaning *
1926 *********************************************************************
1929 IXSQEL = ABS(WHAT(1))
1932 *********************************************************************
1934 * control card: RNDMINIT *
1936 * initialization of random number generator *
1938 * what (1..4) values for initialization (= 1..168) *
1939 * what (5..6), sdum no meaning *
1941 *********************************************************************
1944 IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
1949 IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
1954 IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
1959 IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
1964 CALL DT_RNDMST(NA1,NA2,NA3,NA4)
1967 *********************************************************************
1969 * control card: codewd = LEPTO-CUT *
1971 * set parameter CUT in LEPTO-common /LEPTOU/ *
1973 * what (1) = index in CUT-array *
1974 * what (2) = new value of CUT( int(what(1)) ) *
1975 * what (3), what(4) and what (5), what(6) further *
1976 * parameter in the same way as what (1) and *
1978 * default: default-LEPTO parameters *
1980 *********************************************************************
1983 IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
1984 IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
1985 IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
1988 *********************************************************************
1990 * control card: codewd = LEPTO-LST *
1992 * set parameter LST in LEPTO-common /LEPTOU/ *
1994 * what (1) = index in LST-array *
1995 * what (2) = new value of LST( int(what(1)) ) *
1996 * what (3), what(4) and what (5), what(6) further *
1997 * parameter in the same way as what (1) and *
1999 * default: default-LEPTO parameters *
2001 *********************************************************************
2004 IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
2005 IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
2006 IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
2009 *********************************************************************
2011 * control card: codewd = LEPTO-PARL *
2013 * set parameter PARL in LEPTO-common /LEPTOU/ *
2015 * what (1) = index in PARL-array *
2016 * what (2) = new value of PARL( int(what(1)) ) *
2017 * what (3), what(4) and what (5), what(6) further *
2018 * parameter in the same way as what (1) and *
2020 * default: default-LEPTO parameters *
2022 *********************************************************************
2025 IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
2026 IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
2027 IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
2030 *********************************************************************
2032 * control card: codewd = START *
2034 * what (1) = number of events default: 100. *
2035 * what (2) = 0 Glauber initialization follows *
2036 * = 1 Glauber initialization supressed, fitted *
2037 * results are used instead *
2038 * (this does not apply if emulsion-treatment *
2040 * = 2 Glauber initialization is written to *
2041 * output-file shmakov.out *
2042 * = 3 Glauber initialization is read from input-file *
2043 * shmakov.out default: 0 *
2044 * what (3..6) no meaning *
2045 * what (3..6) no meaning *
2047 *********************************************************************
2051 * check for cross-section table output only
2054 NCASES = INT(WHAT(1))
2055 IF (NCASES.LE.0) NCASES = 100
2056 IGLAU = INT(WHAT(2))
2057 IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
2066 IF (IDP.LE.0) IDP = 1
2067 * muon neutrinos: temporary (missing index)
2068 * (new patch in projpar: therefore the following this is probably not
2069 * necessary anymore..)
2070 C IF (IDP.EQ.26) IDP = 5
2071 C IF (IDP.EQ.27) IDP = 6
2073 * redefine collision energy
2075 IF (ABS(VAREHI).GT.ZERO) THEN
2077 IF (VARELO.LT.EHADLO) VARELO = EHADLO
2078 CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2080 CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2082 CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2085 1003 FORMAT(1X,'INIT: collision energy not defined!',/,
2086 & 1X,' -program stopped- ')
2090 * switch off evaporation (even if requested) if central coll. requ.
2091 IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2094 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since',
2095 & ' central collisions forced.')
2102 * initialization of evaporation-module
2104 * initialize evaporation if the code is not used as Fluka event generator
2105 IF (ITRSPT.NE.1) THEN
2109 IF (LEVPRT) LHEAVY = .TRUE.
2112 * save the default JETSET-parameter
2115 * force use of phojet for g-A
2116 IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2117 * initialization of nucleon-nucleon event generator
2118 IF (MCGENE.EQ.2) CALL DT_PHOINI
2119 * initialization of LEPTO event generator
2120 IF (MCGENE.EQ.3) THEN
2122 STOP ' This version does not contain LEPTO !'
2126 * initialization of quasi-elastic neutrino scattering
2127 IF (MCGENE.EQ.4) THEN
2128 IF (IJPROJ.EQ.5) THEN
2130 ELSEIF (IJPROJ.EQ.6) THEN
2132 ELSEIF (IJPROJ.EQ.135) THEN
2134 ELSEIF (IJPROJ.EQ.136) THEN
2136 ELSEIF (IJPROJ.EQ.133) THEN
2138 ELSEIF (IJPROJ.EQ.134) THEN
2143 * normalize fractions of emulsion components
2144 IF (NCOMPO.GT.0) THEN
2147 SUMFRA = SUMFRA+EMUFRA(I)
2149 IF (SUMFRA.GT.ZERO) THEN
2151 EMUFRA(I) = EMUFRA(I)/SUMFRA
2156 * disallow Cronin's multiple scattering for nucleus-nucleus interactions
2157 IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN
2159 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/)
2163 * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2164 C IF (NCOMPO.LE.0) THEN
2165 C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2168 C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2172 * pre-tabulation of elastic cross-sections
2173 CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2179 *********************************************************************
2181 * control card: codewd = STOP *
2183 * stop of the event generation *
2185 * what (1..6) no meaning *
2187 *********************************************************************
2191 9000 FORMAT(1X,'---> unexpected end of input !')
2198 *===kkinc==============================================================*
2201 SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2204 ************************************************************************
2205 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
2206 * This subroutine is an update of the previous version written *
2207 * by J. Ranft/ H.-J. Moehring. *
2208 * This version dated 19.11.95 is written by S. Roesler *
2209 ************************************************************************
2211 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2214 PARAMETER ( LINP = 5 ,
2218 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2219 & TINY2=1.0D-2,TINY3=1.0D-3)
2225 PARAMETER (NMXHKK=200000)
2227 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2228 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2229 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2230 * extended event history
2231 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2232 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2234 * particle properties (BAMJET index convention)
2236 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2237 & IICH(210),IIBAR(210),K1(210),K2(210)
2238 * properties of interacting particles
2239 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2240 * Lorentz-parameters of the current interaction
2241 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2242 & UMO,PPCM,EPROJ,PPROJ
2243 * flags for input different options
2244 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2245 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2246 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2247 * flags for particle decays
2248 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2249 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2250 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2251 * cuts for variable energy runs
2252 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2253 * Glauber formalism: flags and parameters for statistics
2256 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2263 IF (ILOOP.EQ.4) THEN
2264 WRITE(LOUT,1000) NEVHKK
2265 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
2270 * variable energy-runs, recalculate parameters for LT's
2271 IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2274 CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2276 IF (EPN.GT.EPROJ) THEN
2277 WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2278 & ' Requested energy (',EPN,'GeV) exceeds',
2279 & ' initialization energy (',EPROJ,'GeV) !'
2283 * re-initialize /DTPRTA/
2289 IBPROJ = IIBAR(IJPROJ)
2291 * calculate nuclear potentials (common /DTNPOT/)
2292 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2294 * initialize treatment for residual nuclei
2295 CALL DT_RESNCL(EPN,NLOOP,1)
2297 * sample hadron/nucleus-nucleus interaction
2298 CALL DT_KKEVNT(KKMAT,IREJ1)
2299 IF (IREJ1.GT.0) THEN
2300 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2304 IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2306 * intranuclear cascade of final state particles for KTAUGE generations
2308 CALL DT_FOZOCA(LFZC,IREJ1)
2309 IF (IREJ1.GT.0) THEN
2310 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2314 * baryons unable to escape the nuclear potential are treated as
2315 * excited nucleons (ISTHKK=15,16)
2318 * decay of resonances produced in intranuclear cascade processes
2319 **sr 15-11-95 should be obsolete
2320 C IF (LFZC) CALL DT_DECAY1
2323 * treatment of residual nuclei
2324 CALL DT_RESNCL(EPN,NLOOP,2)
2326 * evaporation / fission / fragmentation
2327 * (if intranuclear cascade was sampled only)
2329 CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2330 IF (IREJ1.GT.1) GOTO 101
2331 IF (IREJ1.EQ.1) GOTO 100
2336 * transform finale state into Lab.
2338 CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2339 IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2341 IF (IPI0.EQ.1) CALL DT_DECPI0
2343 C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2351 *===defaul=============================================================*
2353 CDECK ID>, DT_DEFAUL
2354 SUBROUTINE DT_DEFAUL(EPN,PPN)
2356 ************************************************************************
2357 * Variables are set to default values. *
2358 * This version dated 8.5.95 is written by S. Roesler. *
2359 ************************************************************************
2361 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2363 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2364 PARAMETER (TWOPI = 6.283185307179586454D+00)
2366 * particle properties (BAMJET index convention)
2368 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2369 & IICH(210),IIBAR(210),K1(210),K2(210)
2372 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2373 & EBINDP(2),EBINDN(2),EPOT(2,210),
2374 & ETACOU(2),ICOUL,LFERMI
2375 * interface HADRIN-DPM
2376 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2377 * central particle production, impact parameter biasing
2378 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2379 * properties of interacting particles
2380 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2381 * properties of photon/lepton projectiles
2382 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2384 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2386 * emulsion treatment
2387 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2389 * parameter for intranuclear cascade
2391 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2392 * various options for treatment of partons (DTUNUC 1.x)
2393 * (chain recombination, Cronin,..)
2394 LOGICAL LCO2CR,LINTPT
2395 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2397 * threshold values for x-sampling (DTUNUC 1.x)
2398 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2400 * flags for input different options
2401 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2402 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2403 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2404 * n-n cross section fluctuations
2405 PARAMETER (NBINS = 1000)
2406 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2407 * flags for particle decays
2408 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2409 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2410 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2411 * diquark-breaking mechanism
2412 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2413 * nucleon-nucleon event-generator
2416 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2417 * flags for diffractive interactions (DTUNUC 1.x)
2418 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2419 * VDM parameter for photon-nucleus interactions
2420 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2421 * Glauber formalism: flags and parameters for statistics
2424 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2425 * kinematical cuts for lepton-nucleus interactions
2426 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2427 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2428 * flags for activated histograms
2429 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2430 * cuts for variable energy runs
2431 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2432 * parameters for hA-diffraction
2433 COMMON /DTDIHA/ DIBETA,DIALPH
2436 COMMON /LEPTOI/ RPPN,LEPIN,INTER
2437 * steering flags for qel neutrino scattering modules
2438 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2440 COMMON /DTEVNO/ NEVENT,ICASCA
2442 DATA POTMES /0.002D0/
2453 * nucleus independent meson potential
2462 **sr 7.4.98: changed after corrected B-sampling
2503 **sr 7.4.98: changed after corrected B-sampling
2522 * definition of soft quark distributions
2527 * cutoff parameters for x-sampling
2573 CMODEL(1) = 'DTUNUC '
2574 CMODEL(2) = 'PHOJET '
2575 CMODEL(3) = 'LEPTO '
2576 CMODEL(4) = 'QNEUTRIN'
2613 IF (ITRSPT.EQ.1) THEN
2648 IF (ITRSPT.EQ.1) THEN
2654 * default Lab.-energy
2656 PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2661 *===aaevt==============================================================*
2664 SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2667 ************************************************************************
2668 * This version dated 22.03.96 is written by S. Roesler. *
2669 ************************************************************************
2671 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2674 PARAMETER ( LINP = 5 ,
2678 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2680 * emulsion treatment
2681 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2684 COMMON /DTEVNO/ NEVENT,ICASCA
2686 CHARACTER*8 DATE,HHMMSS
2690 NMSG = MAX(NEVTS/100,1)
2692 * initialization of run-statistics and histograms
2695 CALL PHO_PHIST(1000,DUM)
2697 * initialization of Glauber-formalism
2698 IF (NCOMPO.LE.0) THEN
2699 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2702 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2708 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2709 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2711 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2712 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2713 WRITE(LOUT,1001) DATE,HHMMSS
2714 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2715 & ' Time: ',A8,' )')
2717 * generate NEVTS events
2720 * print run-status message
2721 IF (MOD(IEVT,NMSG).EQ.0) THEN
2723 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2724 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2726 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2727 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2728 WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2729 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2730 & ' Time: ',A,' )',/)
2731 C WRITE(LOUT,1000) IEVT-1
2732 C1000 FORMAT(1X,I8,' events sampled')
2735 * treat nuclear emulsions
2736 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2737 * composite targets only
2740 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2742 CALL PHO_PHIST(2000,DUM)
2746 * print run-statistics and histograms to output-unit 6
2748 CALL PHO_PHIST(3000,DUM)
2755 *===laevt==============================================================*
2758 SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2761 ************************************************************************
2762 * Interface to run DPMJET for lepton-nucleus interactions. *
2763 * Kinematics is sampled using the equivalent photon approximation *
2764 * Based on GPHERA-routine by R. Engel. *
2765 * This version dated 23.03.96 is written by S. Roesler. *
2766 ************************************************************************
2768 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2771 PARAMETER ( LINP = 5 ,
2775 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2776 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2777 PARAMETER (TWOPI = 6.283185307179586454D+00,
2779 & ALPHEM = ONE/137.0D0)
2781 C CHARACTER*72 HEADER
2783 * particle properties (BAMJET index convention)
2785 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2786 & IICH(210),IIBAR(210),K1(210),K2(210)
2789 PARAMETER (NMXHKK=200000)
2791 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2792 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2793 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2794 * extended event history
2795 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2796 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2798 * kinematical cuts for lepton-nucleus interactions
2799 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2800 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2801 * properties of interacting particles
2802 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2803 * properties of photon/lepton projectiles
2804 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2805 * kinematics at lepton-gamma vertex
2806 COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2807 * flags for activated histograms
2808 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2810 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2812 * emulsion treatment
2813 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2815 * Glauber formalism: cross sections
2816 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2817 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2818 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2819 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2820 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2821 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2822 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2823 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2824 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2825 & BSLOPE,NEBINI,NQBINI
2826 * nucleon-nucleon event-generator
2829 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2830 * flags for input different options
2831 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2832 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2833 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2835 COMMON /DTEVNO/ NEVENT,ICASCA
2837 DIMENSION XDUMB(40),BGTA(4)
2840 IF (MCGENE.EQ.3) THEN
2842 STOP ' This version does not contain LEPTO !'
2847 NMSG = MAX(NEVTS/10,1)
2849 * mass of incident lepton
2852 IDPPDG = IDT_IPDGHA(IDP)
2854 * consistency of kinematical limits
2855 Q2MIN = MAX(Q2MIN,TINY10)
2856 Q2MAX = MAX(Q2MAX,TINY10)
2857 YMIN = MIN(MAX(YMIN,TINY10),0.999D0)
2858 YMAX = MIN(MAX(YMAX,TINY10),0.999D0)
2860 * total energy of the lepton-nucleon system
2861 PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2862 & +(PLEPT0(3)+PNUCL(3))**2 )
2863 ETOTLN = PLEPT0(4)+PNUCL(4)
2864 ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2865 ECMAX = MIN(ECMAX,ECMLN)
2866 WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2868 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2869 & '------------------',/,9X,'W (min) =',
2870 & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =',
2871 & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2872 & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) ='
2873 & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2874 & F7.4,' for E_lpt >',F7.1,' GeV',/)
2876 * Lorentz-parameter for transf. into Lab
2877 BGTA(1) = PNUCL(1)/AAM(1)
2878 BGTA(2) = PNUCL(2)/AAM(1)
2879 BGTA(3) = PNUCL(3)/AAM(1)
2880 BGTA(4) = PNUCL(4)/AAM(1)
2881 * LT of incident lepton into Lab and dump it in DTEVT1
2882 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2883 & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2884 & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2885 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2886 & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2887 & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2888 * maximum energy of photon nucleon system
2889 PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2890 & +(YMAX*PPL0(3)+PPA(3))**2)
2891 ETOTGN = YMAX*PPL0(4)+PPA(4)
2892 EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2893 EGNMAX = MIN(EGNMAX,ECMAX)
2894 * minimum energy of photon nucleon system
2895 PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2896 & +(YMIN*PPL0(3)+PPA(3))**2)
2897 ETOTGN = YMIN*PPL0(4)+PPA(4)
2898 EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2899 EGNMIN = MAX(EGNMIN,ECMIN)
2901 * limits for Glauber-initialization
2903 Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2904 ECMLI = MAX(EGNMIN,THREE)
2906 WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2907 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1,
2908 & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ',
2909 & 'Glauber-initialization:',/,9X,'W (min) =',F7.1,
2910 & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2911 & ' GeV^2 (max) =',F7.1,' GeV^2',/)
2912 * initialization of Glauber-formalism
2913 IF (NCOMPO.LE.0) THEN
2914 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2917 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2922 * initialization of run-statistics and histograms
2925 CALL PHO_PHIST(1000,DUM)
2927 * maximum photon-nucleus cross section
2931 IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2935 ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2937 IF (EGNMAX.LT.ECMNN(I)) THEN
2940 RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2946 SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2951 IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2955 ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2957 IF (EGNMIN.LT.ECMNN(I)) THEN
2960 RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2966 SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2967 IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2968 SIGMAX = MAX(SIGMAX,SIGXX)
2969 WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2971 * plot photon flux table
2976 ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2977 C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
2979 Y = EXP(AYMIN+ADY*DBLE(I-1))
2980 Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2981 FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2982 & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2983 FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2984 & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2985 C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2988 * maximum residual weight for flux sampling (dy/y)
2990 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2991 WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2992 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2994 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2995 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2996 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2997 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2998 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2999 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
3000 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
3001 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
3002 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
3003 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
3004 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
3005 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
3007 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
3008 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
3009 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
3018 IF (MOD(IEVT,NMSG).EQ.0) THEN
3019 C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
3020 C & STATUS='UNKNOWN')
3021 WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
3032 YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
3033 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
3034 Q2LOG = LOG(Q2MAX/Q2LOW)
3035 WGH = (ONE+(ONE-YY)**2)*Q2LOG
3036 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
3037 IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
3038 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5)
3039 IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
3042 YEFF = ONE+(ONE-YY)**2
3044 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
3045 WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
3046 IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
3049 c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3050 c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3052 * kinematics at lepton-photon vertex
3053 * scattered electron
3054 YQ2 = SQRT((ONE-YY)*Q2)
3055 Q2E = Q2/(4.0D0*PLEPT0(4))
3056 E1Y = (ONE-YY)*PLEPT0(4)
3057 CALL DT_DSFECF(SIF,COF)
3062 C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3064 PGAMM(1) = -PLEPT1(1)
3065 PGAMM(2) = -PLEPT1(2)
3066 PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3067 PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3069 PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3070 & +(PGAMM(3)+PNUCL(3))**2 )
3071 ETOTGN = PGAMM(4)+PNUCL(4)
3072 ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3073 IF (ECMGN.LT.0.1D0) GOTO 101
3075 IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3077 * Lorentz-transformation into nucleon-rest system
3078 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3079 & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3080 & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3081 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3082 & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3083 & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3084 * temporary checks..
3085 Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3086 IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3087 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ',
3089 ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3090 IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3091 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ',
3093 YYTMP = PPG(4)/PPL0(4)
3094 IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3095 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ',
3098 * lepton tagger (Lab)
3099 THETA = ACOS( PPL1(3)/PLTOT )
3100 IF (PPL1(4).GT.ELMIN) THEN
3101 IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3103 * photon energy-cut (Lab)
3104 IF (PPG(4).LT.EGMIN) GOTO 101
3105 IF (PPG(4).GT.EGMAX) GOTO 101
3107 XBJ = ABS(Q2/(1.876D0*PPG(4)))
3108 IF (XBJ.LT.XBJMIN) GOTO 101
3111 CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0)
3112 CALL DT_FILHGR( YY,ONE,IHFLY0,NC0)
3113 CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0)
3114 CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3115 CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3117 * rotation angles against z-axis
3119 C SID = SQRT((ONE-COD)*(ONE+COD))
3120 PPT = SQRT(PPG(1)**2+PPG(2)**2)
3124 IF (PGTOT*SID.GT.TINY10) THEN
3125 COF = PPG(1)/(SID*PGTOT)
3126 SIF = PPG(2)/(SID*PGTOT)
3127 ANORF = SQRT(COF*COF+SIF*SIF)
3132 IF (IXSTBL.EQ.0) THEN
3133 * change to photon projectile
3137 * re-initialize LTs with new kinematics
3138 * !!PGAMM ist set in cms (ECMGN) along z
3141 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3142 * Introduced by Chiara -> force CMS-system
3144 * to force Lab-system
3146 * get emulsion component if requested
3147 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3148 * convolute with cross section
3149 CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3150 CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3151 IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3152 & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3154 IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3156 CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1)
3157 CALL DT_FILHGR( YY,ONE,IHFLY1,NC1)
3158 CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1)
3159 CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3160 CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3161 * composite targets only
3164 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3166 * rotate momenta of final state particles back in photon-nucleon syst.
3167 DO 4 I=NPOINT(4),NHKK
3168 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3169 & (ISTHKK(I).EQ.1001)) THEN
3173 CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3174 & PHKK(1,I),PHKK(2,I),PHKK(3,I))
3179 CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1)
3180 CALL DT_FILHGR( YY,ONE,IHFLY2,NC1)
3181 CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1)
3182 CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3183 CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3185 * dump this event to histograms
3187 CALL PHO_PHIST(2000,DUM)
3191 WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3192 WGY = WGY*LOG(YMAX/YMIN)
3193 WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3195 C HEADER = ' LAEVT: Q^2 distribution 0'
3196 C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3197 C HEADER = ' LAEVT: Q^2 distribution 1'
3198 C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3199 C HEADER = ' LAEVT: Q^2 distribution 2'
3200 C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3201 C HEADER = ' LAEVT: y distribution 0'
3202 C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3203 C HEADER = ' LAEVT: y distribution 1'
3204 C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3205 C HEADER = ' LAEVT: y distribution 2'
3206 C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3207 C HEADER = ' LAEVT: x distribution 0'
3208 C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3209 C HEADER = ' LAEVT: x distribution 1'
3210 C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3211 C HEADER = ' LAEVT: x distribution 2'
3212 C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3213 C HEADER = ' LAEVT: E_g distribution 0'
3214 C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3215 C HEADER = ' LAEVT: E_g distribution 1'
3216 C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3217 C HEADER = ' LAEVT: E_g distribution 2'
3218 C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3219 C HEADER = ' LAEVT: E_c distribution 0'
3220 C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3221 C HEADER = ' LAEVT: E_c distribution 1'
3222 C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3223 C HEADER = ' LAEVT: E_c distribution 2'
3224 C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3226 * print run-statistics and histograms to output-unit 6
3228 CALL PHO_PHIST(3000,DUM)
3230 IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3235 *===dtuini=============================================================*
3237 CDECK ID>, DT_DTUINI
3238 SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3241 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3244 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3246 * emulsion treatment
3247 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3249 * Glauber formalism: flags and parameters for statistics
3252 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3254 CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3257 CALL PHO_PHIST(1000,DUM)
3259 IF (NCOMPO.LE.0) THEN
3260 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3263 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3266 IF (IOGLB.NE.100) CALL DT_SIGEMU
3272 *===dtuout=============================================================*
3274 CDECK ID>, DT_DTUOUT
3275 SUBROUTINE DT_DTUOUT
3277 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3280 CALL PHO_PHIST(3000,DUM)
3287 *===beam===============================================================*
3289 CDECK ID>, DT_BEAMPR
3290 SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3292 ************************************************************************
3293 * Initialization of event generation *
3294 * This version dated 7.4.98 is written by S. Roesler. *
3295 ************************************************************************
3297 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3300 PARAMETER ( LINP = 5 ,
3304 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3305 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3311 PARAMETER (NMXHKK=200000)
3313 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3314 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3315 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3316 * extended event history
3317 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3318 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3320 * properties of interacting particles
3321 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3322 * particle properties (BAMJET index convention)
3324 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3325 & IICH(210),IIBAR(210),K1(210),K2(210)
3327 COMMON /DTBEAM/ P1(4),P2(4)
3329 C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3330 DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3332 DATA LBEAM /.FALSE./
3339 IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3341 IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3342 PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3343 PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3344 TH = 1.D-6*WHAT(3)/2.D0
3346 P1(1) = PP1*SIN(TH)*COS(PH)
3347 P1(2) = PP1*SIN(TH)*SIN(PH)
3350 P2(1) = PP2*SIN(TH)*COS(PH)
3351 P2(2) = PP2*SIN(TH)*SIN(PH)
3352 P2(3) = -PP2*COS(TH)
3354 ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3355 & -(P1(3)+P2(3))**2 )
3356 ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3357 PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3358 BGX = (P1(1)+P2(1))/ECM
3359 BGY = (P1(2)+P2(2))/ECM
3360 BGZ = (P1(3)+P2(3))/ECM
3361 BGE = (P1(4)+P2(4))/ECM
3362 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3363 & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3364 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3365 & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3366 COD = P1CMS(3)/P1TOT
3367 C SID = SQRT((ONE-COD)*(ONE+COD))
3368 PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3372 IF (P1TOT*SID.GT.TINY10) THEN
3373 COF = P1CMS(1)/(SID*P1TOT)
3374 SIF = P1CMS(2)/(SID*P1TOT)
3375 ANORF = SQRT(COF*COF+SIF*SIF)
3380 C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3381 C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3382 C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3383 C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3387 C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3391 C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3392 C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3393 C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3394 C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3395 C & P1CMS(1),P1CMS(2),P1CMS(3))
3396 C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3397 C & P2CMS(1),P2CMS(2),P2CMS(3))
3398 C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3399 C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3400 C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3401 C & P1TOT,P1(1),P1(2),P1(3),P1(4))
3402 C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3403 C & P2TOT,P2(1),P2(2),P2(3),P2(4))
3404 C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3405 C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3416 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3417 DO 20 I=NPOINT(4),NHKK
3418 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3419 & (ISTHKK(I).EQ.1001)) THEN
3420 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3421 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3423 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3424 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3434 *===eventb=============================================================*
3436 CDECK ID>, DT_EVENTB
3437 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3439 ************************************************************************
3440 * Treatment of nucleon-nucleon interactions with full two-component *
3441 * Dual Parton Model. *
3442 * NCSY number of nucleon-nucleon interactions *
3443 * IREJ rejection flag *
3444 * This version dated 14.01.2000 is written by S. Roesler *
3445 ************************************************************************
3447 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3450 PARAMETER ( LINP = 5 ,
3454 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3458 PARAMETER (NMXHKK=200000)
3460 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3461 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3462 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3463 * extended event history
3464 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3465 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3467 *! uncomment this line for internal phojet-fragmentation
3468 C #include "dtu_dtevtp.inc"
3469 * particle properties (BAMJET index convention)
3471 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3472 & IICH(210),IIBAR(210),K1(210),K2(210)
3473 * flags for input different options
3474 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3475 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3476 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3478 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3479 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3480 & IREXCI(3),IRDIFF(2),IRINC
3481 * properties of interacting particles
3482 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3483 * properties of photon/lepton projectiles
3484 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3485 * various options for treatment of partons (DTUNUC 1.x)
3486 * (chain recombination, Cronin,..)
3487 LOGICAL LCO2CR,LINTPT
3488 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3491 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3492 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3494 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3495 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3496 * Glauber formalism: collision properties
3497 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3498 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3499 * flags for diffractive interactions (DTUNUC 1.x)
3500 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3501 * statistics: double-Pomeron exchange
3502 COMMON /DTFLG2/ INTFLG,IPOPO
3503 * flags for particle decays
3504 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3505 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3506 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3507 * nucleon-nucleon event-generator
3510 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3511 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3512 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3513 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3514 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3515 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3516 C model switches and parameters
3518 INTEGER ISWMDL,IPAMDL
3519 DOUBLE PRECISION PARMDL
3520 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3521 C initial state parton radiation (internal part)
3522 INTEGER MXISR3,MXISR4
3523 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3524 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3525 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3526 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3527 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3528 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3529 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3530 C event debugging information
3532 PARAMETER (NMAXD=100)
3533 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3534 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3535 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3536 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3537 C general process information
3538 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3539 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3541 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3542 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3543 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3544 & KPRON(15),ISINGL(2000)
3546 * initial values for max. number of phojet scatterings and dtunuc chains
3547 * to be fragmented with one pyexec call
3548 DATA MXPHFR,MXDTFR /10,100/
3551 * pointer to first parton of the first chain in dtevt common
3553 * special flag for double-Pomeron statistics
3555 * counter for low-mass (DTUNUC) interactions
3557 * counter for interactions treated by PHOJET
3560 * scan interactions for single nucleon-nucleon interactions
3561 * (this has to be checked here because Cronin modifies parton momenta)
3563 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3567 MOT = JMOHKK(1,NC+1)
3568 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3569 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3570 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3574 * multiple scattering of chain ends
3575 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3576 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3578 * switch to PHOJET-settings for JETSET parameter
3581 * loop over nucleon-nucleon interaction
3585 * pick up one nucleon-nucleon interaction from DTEVT1
3586 * ppnn / ptnn - momenta of the interacting nucleons (cms)
3587 * ptotnn - total momentum of the interacting nucleons (cms)
3588 * pp1,2 / pt1,2 - momenta of the four partons
3589 * pp / pt - total momenta of the proj / targ partons
3590 * ptot - total momentum of the four partons
3592 MOT = JMOHKK(1,NC+1)
3594 PPNN(K) = PHKK(K,MOP)
3595 PTNN(K) = PHKK(K,MOT)
3596 PTOTNN(K) = PPNN(K)+PTNN(K)
3598 PT1(K) = PHKK(K,NC+1)
3599 PP2(K) = PHKK(K,NC+2)
3600 PT2(K) = PHKK(K,NC+3)
3601 PP(K) = PP1(K)+PP2(K)
3602 PT(K) = PT1(K)+PT2(K)
3603 PTOT(K) = PP(K)+PT(K)
3606 *-----------------------------------------------------------------------
3607 * this is a complete nucleon-nucleon interaction
3609 IF (ISINGL(I).EQ.1) THEN
3611 * initialize PHOJET-variables for remnant/valence-partons
3618 * save current settings of PHOJET process and min. bias flags
3620 KPRON(K) = IPRON(K,1)
3624 * check if forced sampling of diffractive interaction requested
3625 IF (ISINGD.LT.-1) THEN
3629 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3630 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3631 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3634 * for photons: a direct/anomalous interaction is not sampled
3635 * in PHOJET but already in Glauber-formalism. Here we check if such
3636 * an interaction is requested
3637 IF (IJPROJ.EQ.7) THEN
3638 * first switch off direct interactions
3640 * this is a direct interactions
3641 IF (IDIREC.EQ.1) THEN
3646 * this is an anomalous interactions
3647 * (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3648 ELSEIF (IDIREC.EQ.2) THEN
3652 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3655 * make sure that total momenta of partons, pp and pt, are on mass
3656 * shell (Cronin may have srewed this up..)
3657 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3659 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3660 & 'EVENTB: mass shell correction rejected'
3664 * initialize the incoming particles in PHOJET
3665 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3667 CALL PHO_SETPAR(1,22,0,VIRT)
3671 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3675 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3678 * initialize rejection loop counter for anomalous processes
3683 * temporary fix for ifano problem
3687 * generate complete hadron/nucleon/photon-nucleon event with PHOJET
3689 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3692 * for photons: special consistency check for anomalous interactions
3693 IF (IJPROJ.EQ.7) THEN
3694 IF (IRJANO.LT.30) THEN
3695 IF (IFANO(1).NE.0) THEN
3696 * here, an anomalous interaction was generated. Check if it
3697 * was also requested. Otherwise reject this event.
3698 IF (IDIREC.EQ.0) GOTO 800
3700 * here, an anomalous interaction was not generated. Check if it
3701 * was requested in which case we need to reject this event.
3702 IF (IDIREC.EQ.2) GOTO 800
3705 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3706 & IRJANO,IDIREC,NEVHKK
3710 * copy back original settings of PHOJET process and min. bias flags
3712 IPRON(K,1) = KPRON(K)
3716 * check if PHOJET has rejected this event
3717 IF (IREJ1.NE.0) THEN
3718 C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3719 WRITE(LOUT,'(1X,A,I4)')
3720 & 'EVENTB: chain system rejected',IDIREC
3727 * copy partons and strings from PHOJET common back into DTEVT for
3728 * external fragmentation
3731 *! uncomment this line for internal phojet-fragmentation
3732 C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3734 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3735 IF (IREJ1.NE.0) THEN
3737 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3741 * update statistics counter
3742 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3744 *-----------------------------------------------------------------------
3745 * this interaction involves "remnants"
3749 * total mass of this system
3750 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3751 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3752 IF (AMTOT2.LT.ZERO) THEN
3755 AMTOT = SQRT(AMTOT2)
3758 * systems with masses larger than elojet are treated with PHOJET
3759 IF (AMTOT.GT.ELOJET) THEN
3761 * initialize PHOJET-variables for remnant/valence-partons
3762 * projectile parton flavors and valence flag
3763 IHFLD(1,1) = IDHKK(NC)
3764 IHFLD(1,2) = IDHKK(NC+2)
3766 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3767 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3768 * target parton flavors and valence flag
3769 IHFLD(2,1) = IDHKK(NC+1)
3770 IHFLD(2,2) = IDHKK(NC+3)
3772 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3773 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3774 * flag signalizing PHOJET how to treat the remnant:
3775 * iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3776 * iremn > -1 valence remnant: PHOJET assumes flavors according
3777 * to mother particle
3781 * initialize the incoming particles in PHOJET
3782 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3784 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3788 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3792 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3795 * calculate Lorentz parameter of the nucleon-nucleon cm-system
3796 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3797 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3798 BGX = PTOTNN(1)/AMNN
3799 BGY = PTOTNN(2)/AMNN
3800 BGZ = PTOTNN(3)/AMNN
3801 GAM = PTOTNN(4)/AMNN
3802 * transform interacting nucleons into nucleon-nucleon cm-system
3803 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3804 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3805 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3806 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3807 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3808 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3809 * transform (total) momenta of the proj and targ partons into
3810 * nucleon-nucleon cm-system
3811 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3812 & PP(1),PP(2),PP(3),PP(4),
3813 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3814 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3815 & PT(1),PT(2),PT(3),PT(4),
3816 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3817 * energy fractions of the proj and targ partons
3818 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3819 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3822 c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3823 c & (PPTCMS(2)+PTTCMS(2))**2 +
3824 c & (PPTCMS(3)+PTTCMS(3))**2 )
3825 c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3826 c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3827 c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3828 c & (PPSUB(2)+PTSUB(2))**2 +
3829 c & (PPSUB(3)+PTSUB(3))**2 )
3830 c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3831 c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3834 * save current settings of PHOJET process and min. bias flags
3836 KPRON(K) = IPRON(K,1)
3838 * disallow direct photon int. (does not make sense here anyway)
3840 * disallow double pomeron processes (due to technical problems
3841 * in PHOJET, needs to be solved sometime)
3843 * disallow diffraction for sea-diquarks
3844 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3845 & (IABS(IHFLD(1,2)).GT.1100)) THEN
3849 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3850 & (IABS(IHFLD(2,2)).GT.1100)) THEN
3855 * we need massless partons: transform them on mass shell
3862 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3863 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3864 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3865 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3866 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3867 * total energy of the subsysten after mass transformation
3868 * (should be the same as before..)
3869 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3870 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
3872 * after mass shell transformation the x_sub - relation has to be
3873 * corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3875 * The old version was to scale based on the original x_sub and the
3876 * 4-momenta of the subsystem. At very high energy this could lead to
3877 * "pseudo-cm energies" of the parent system considerably exceeding
3878 * the true cm energy. Now we keep the true cm energy and calculate
3879 * new x_sub instead.
3880 C old version PPTCMS(4) = PPSUB(4)/XPSUB
3881 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3882 XPSUB = PPSUB(4)/PPTCMS(4)
3883 IF (IJPROJ.EQ.7) THEN
3884 AMP2 = PHKK(5,MOT)**2
3885 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3888 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3889 & *(PPTCMS(4)+PHKK(5,MOP)))
3890 C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3891 C & *(PPTCMS(4)+PHKK(5,MOT)))
3893 C old version PTTCMS(4) = PTSUB(4)/XTSUB
3894 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3895 XTSUB = PTSUB(4)/PTTCMS(4)
3896 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3897 & *(PTTCMS(4)+PHKK(5,MOT)))
3899 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3900 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3905 * ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
3906 * ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
3907 * pptcms/ pttcms - momenta of the interacting nucleons (cms)
3908 * pp1,2 / pt1,2 - momenta of the four partons
3910 * pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
3911 * ptot - total momentum of the four partons (cms, negl. Fermi)
3912 * ppsub / ptsub - total momenta of the proj / targ partons (cms)
3914 c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3915 c & (PPTCMS(2)+PTTCMS(2))**2 +
3916 c & (PPTCMS(3)+PTTCMS(3))**2 )
3917 c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3918 c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3919 c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3920 c & (PPSUB(2)+PTSUB(2))**2 +
3921 c & (PPSUB(3)+PTSUB(3))**2 )
3922 c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3923 c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3924 c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3925 c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3926 c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3927 c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
3929 c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3930 c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3931 c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3932 c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3933 * transform interacting nucleons into nucleon-nucleon cm-system
3934 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3935 c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3936 c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3937 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3938 c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3939 c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3940 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3941 c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3942 c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3943 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3944 c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3945 c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3946 c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3947 c & (PPNEW2+PTNEW2)**2 +
3948 c & (PPNEW3+PTNEW3)**2 )
3949 c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3950 c & (PPNEW4+PTNEW4+PTSTCM) )
3951 c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3952 c & (PPSUB2+PTSUB2)**2 +
3953 c & (PPSUB3+PTSUB3)**2 )
3954 c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3955 c & (PPSUB4+PTSUB4+PTSTSU) )
3956 C WRITE(*,*) ' mother cmE :'
3957 C WRITE(*,*) ETSTCM,ENEWCM
3958 C WRITE(*,*) ' subsystem cmE :'
3959 C WRITE(*,*) ETSTSU,ENEWSU
3960 C WRITE(*,*) ' projectile mother :'
3961 C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3962 C WRITE(*,*) ' target mother :'
3963 C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3964 C WRITE(*,*) ' projectile subsystem:'
3965 C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3966 C WRITE(*,*) ' target subsystem:'
3967 C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3968 C WRITE(*,*) ' projectile subsystem should be:'
3969 C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3970 C & XPSUB*ETSTCM/2.0D0
3971 C WRITE(*,*) ' target subsystem should be:'
3972 C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3973 C & XTSUB*ETSTCM/2.0D0
3974 C WRITE(*,*) ' subsystem cmE should be: '
3975 C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3978 * generate complete remnant - nucleon/remnant event with PHOJET
3980 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3983 * copy back original settings of PHOJET process flags
3985 IPRON(K,1) = KPRON(K)
3988 * check if PHOJET has rejected this event
3989 IF (IREJ1.NE.0) THEN
3991 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
3993 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
4000 * copy partons and strings from PHOJET common back into DTEVT for
4001 * external fragmentation
4004 *! uncomment this line for internal phojet-fragmentation
4005 C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
4007 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
4008 IF (IREJ1.NE.0) THEN
4009 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
4010 & 'EVENTB: chain system rejected 2'
4014 * update statistics counter
4015 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4017 *-----------------------------------------------------------------------
4018 * two-chain approx. for smaller systems
4023 * special flag for double-Pomeron statistics
4026 * pick up flavors at the ends of the two chains
4031 * ..and the indices of the mothers
4036 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4037 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4039 * check if this chain system was rejected
4040 IF (IREJ1.GT.0) THEN
4041 IF (IOULEV(1).GT.0) THEN
4042 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4043 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4044 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4049 * the following lines are for sea-sea chains rejected in GETCSY
4050 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4051 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4056 * update statistics counter
4057 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4063 *-----------------------------------------------------------------------
4064 * treatment of low-mass chains (if there are any)
4066 IF (NDTUSC.GT.0) THEN
4068 * correct chains of very low masses for possible resonances
4069 IF (IRESCO.EQ.1) THEN
4070 CALL DT_EVTRES(IREJ1)
4071 IF (IREJ1.GT.0) THEN
4072 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4073 IRRES(1) = IRRES(1)+1
4077 * fragmentation of low-mass chains
4078 *! uncomment this line for internal phojet-fragmentation
4079 * (of course it will still be fragmented by DPMJET-routines but it
4080 * has to be done here instead of further below)
4081 C CALL DT_EVTFRA(IREJ1)
4082 C IF (IREJ1.GT.0) THEN
4083 C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4088 *! uncomment this line for internal phojet-fragmentation
4089 C NPOINT(4) = NHKK+1
4090 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4093 *-----------------------------------------------------------------------
4094 * new di-quark breaking mechanisms
4098 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4099 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4104 *-----------------------------------------------------------------------
4105 * hadronize this event
4107 * hadronize PHOJET chain systems
4109 NPJE = NPHOSC/MXPHFR
4110 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4112 NLEFT = NPHOSC-NPJE*MXPHFR
4115 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4116 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4117 IF (IREJ1.GT.0) GOTO 22
4120 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4121 IF (IREJ1.GT.0) GOTO 22
4123 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4125 IF (NLEFT.GT.0) THEN
4126 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4127 IF (IREJ1.GT.0) GOTO 22
4128 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4131 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4132 IF (IREJ1.GT.0) GOTO 22
4133 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4136 * check max. filling level of jetset common and
4137 * reduce mxphfr if necessary
4138 IF (NPYMAX.GT.3000) THEN
4139 IF (NPYMAX.GT.3500) THEN
4140 MXPHFR = MAX(1,MXPHFR-2)
4142 MXPHFR = MAX(1,MXPHFR-1)
4144 C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4147 * hadronize DTUNUC chain systems
4150 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4151 IF (IREJ2.GT.0) GOTO 22
4153 * check max. filling level of jetset common and
4154 * reduce mxdtfr if necessary
4155 IF (NPYMEM.GT.3000) THEN
4156 IF (NPYMEM.GT.3500) THEN
4157 MXDTFR = MAX(1,MXDTFR-20)
4159 MXDTFR = MAX(1,MXDTFR-10)
4161 C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4164 IF (IBACK.EQ.-1) GOTO 23
4167 C CALL DT_EVTFRG(1,IREJ1)
4168 C CALL DT_EVTFRG(2,IREJ2)
4169 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4170 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4175 * get final state particles from /DTEVTP/
4176 *! uncomment this line for internal phojet-fragmentation
4177 C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4180 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4181 C IF (IREJ3.NE.0) GOTO 9999
4191 *===getpje=============================================================*
4193 CDECK ID>, DT_GETPJE
4194 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4196 ************************************************************************
4197 * This subroutine copies PHOJET partons and strings from POEVT1 into *
4199 * MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4200 * PP,PT 4-momenta of projectile/target being handled by *
4202 * This version dated 11.12.99 is written by S. Roesler *
4203 ************************************************************************
4205 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4208 PARAMETER ( LINP = 5 ,
4212 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4213 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4219 PARAMETER (NMXHKK=200000)
4221 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4222 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4223 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4224 * extended event history
4225 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4226 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4228 * Lorentz-parameters of the current interaction
4229 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4230 & UMO,PPCM,EPROJ,PPROJ
4231 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4232 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4233 * flags for input different options
4234 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4235 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4236 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4237 * statistics: double-Pomeron exchange
4238 COMMON /DTFLG2/ INTFLG,IPOPO
4240 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4241 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4244 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4245 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4246 & IREXCI(3),IRDIFF(2),IRINC
4248 C standard particle data interface
4251 PARAMETER (NMXHEP=4000)
4253 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4254 DOUBLE PRECISION PHEP,VHEP
4255 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4256 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4258 C extension to standard particle data interface (PHOJET specific)
4259 INTEGER IMPART,IPHIST,ICOLOR
4260 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4262 C color string configurations including collapsed strings and hadrons
4264 PARAMETER (MSTR=500)
4265 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4266 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4267 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4268 & NNCH(MSTR),IBHAD(MSTR),ISTR
4269 C general process information
4270 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4271 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4272 C model switches and parameters
4274 INTEGER ISWMDL,IPAMDL
4275 DOUBLE PRECISION PARMDL
4276 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4277 C event debugging information
4279 PARAMETER (NMAXD=100)
4280 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4281 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4282 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4283 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4285 DIMENSION PP(4),PT(4)
4295 * store initial momenta for energy-momentum conservation check
4297 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4298 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4300 * copy partons and strings from POEVT1 into DTEVT1
4302 C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4303 IF (NCODE(I).EQ.-99) THEN
4305 IDSTG = IDHEP(IDXSTG)
4312 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4319 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4322 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4325 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4332 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4336 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4338 ELSEIF (NCODE(I).GE.0) THEN
4339 * indices of partons and string in POEVT1
4340 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4341 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4342 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4343 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4344 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4348 * find "mother" string of the string
4349 IDXMS1 = ABS(JMOHEP(1,IDX1))
4350 IDXMS2 = ABS(JMOHEP(1,IDX2))
4351 IF (IDXMS1.NE.IDXMS2) THEN
4354 C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4356 * search POEVT1 for the original hadron of the parton
4362 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4364 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4365 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4366 & (ILOOP.LT.MAXLOP)) GOTO 14
4367 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4373 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4375 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4376 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4378 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4380 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4381 & (ILOOP.LT.MAXLOP)) GOTO 15
4382 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4384 IF (IDXMS1.EQ.1) THEN
4385 ISPTN1 = ISTHKK(MO1)
4389 ISPTN1 = ISTHKK(MO2)
4394 IF (IDXMS2.EQ.1) THEN
4395 ISPTN2 = ISTHKK(MO1)
4399 ISPTN2 = ISTHKK(MO2)
4403 * check for mis-identified mothers and switch mother indices if necessary
4404 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4405 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4407 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4408 ISPTN1 = ISTHKK(MO1)
4411 ISPTN2 = ISTHKK(MO2)
4415 ISPTN1 = ISTHKK(MO2)
4418 ISPTN2 = ISTHKK(MO1)
4423 * register partons in temporary common
4424 * parton at chain end
4429 * flag only partons coming from Pomeron with 41/42
4430 C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4431 IF (IPOM1.NE.0) THEN
4432 ISTX = ABS(ISPTN1)/10
4433 IMO = ABS(ISPTN1)-10*ISTX
4436 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4437 ISTX = ABS(ISPTN1)/10
4438 IMO = ABS(ISPTN1)-10*ISTX
4439 IF ((IDHEP(IDX1).EQ.21).OR.
4440 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4447 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4448 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4450 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4453 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4455 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4458 IHIST(1,NHKK) = IPHIST(1,IDX1)
4461 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4462 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4464 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4465 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4468 NGLUON = IDX2-IDX1-1
4469 IF (NGLUON.GT.0) THEN
4470 DO 17 IGLUON=1,NGLUON
4472 IDXMS = ABS(JMOHEP(1,IDX))
4473 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4477 IDXMS = ABS(JMOHEP(1,IDXMS))
4478 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4479 & (ILOOP.LT.MAXLOP)) GOTO 16
4480 IF (ILOOP.EQ.MAXLOP)
4481 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4483 IF (IDXMS.EQ.1) THEN
4496 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4497 ISTX = ABS(ISPTN)/10
4498 IMO = ABS(ISPTN)-10*ISTX
4499 IF ((IDHEP(IDX).EQ.21).OR.
4500 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4506 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4507 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4509 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4510 & PX,PY,PZ,PE,0,0,0)
4512 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4514 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4515 & PPX,PPY,PPZ,PPE,0,0,0)
4517 IHIST(1,NHKK) = IPHIST(1,IDX)
4520 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4521 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4523 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4524 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4527 * parton at chain end
4532 * flag only partons coming from Pomeron with 41/42
4533 C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4534 IF (IPOM2.NE.0) THEN
4535 ISTX = ABS(ISPTN2)/10
4536 IMO = ABS(ISPTN2)-10*ISTX
4539 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4540 ISTX = ABS(ISPTN2)/10
4541 IMO = ABS(ISPTN2)-10*ISTX
4542 IF ((IDHEP(IDX2).EQ.21).OR.
4543 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4550 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4551 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4553 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4554 & PX,PY,PZ,PE,0,0,0)
4556 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4558 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4559 & PPX,PPY,PPZ,PPE,0,0,0)
4561 IHIST(1,NHKK) = IPHIST(1,IDX2)
4564 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4565 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4567 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4568 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4571 JSTRG = 100*IPROCE+NCODE(I)
4578 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4579 & PX,PY,PZ,PE,0,0,0)
4585 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4588 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4591 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4592 & PPX,PPY,PPZ,PPE,0,0,0)
4598 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4605 VHKK(KK,NHKK) = VHKK(KK,MO2)
4606 WHKK(KK,NHKK) = WHKK(KK,MO1)
4608 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4609 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4613 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4620 IF (UMO.GT.1.0D5) THEN
4625 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4627 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4631 * internal statistics
4632 * dble-Po statistics.
4633 IF (IPROCE.NE.4) IPOPO = 0
4637 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4638 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4640 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4641 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4642 & ') at evt(chain) ',I6,'(',I2,')')
4644 IF (IPROCE.EQ.5) THEN
4645 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4646 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4648 C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4649 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4650 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4652 ELSEIF (IPROCE.EQ.6) THEN
4653 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4654 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4656 C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4658 ELSEIF (IPROCE.EQ.7) THEN
4659 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4660 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4661 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4662 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4663 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4664 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4665 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4666 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4667 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4668 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4670 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4673 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4675 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4676 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4677 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4679 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4680 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4681 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4682 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4683 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4692 *===phoini=============================================================*
4694 CDECK ID>, DT_PHOINI
4695 SUBROUTINE DT_PHOINI
4697 ************************************************************************
4698 * Initialization PHOJET-event generator for nucleon-nucleon interact. *
4699 * This version dated 16.11.95 is written by S. Roesler *
4700 * Last change: s.r. 21.01.01 *
4701 ************************************************************************
4703 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4706 PARAMETER ( LINP = 5 ,
4710 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4712 * nucleon-nucleon event-generator
4715 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4716 * particle properties (BAMJET index convention)
4718 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4719 & IICH(210),IIBAR(210),K1(210),K2(210)
4720 * Lorentz-parameters of the current interaction
4721 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4722 & UMO,PPCM,EPROJ,PPROJ
4723 * properties of interacting particles
4724 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4725 * properties of photon/lepton projectiles
4726 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4728 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4730 * emulsion treatment
4731 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4733 * VDM parameter for photon-nucleus interactions
4734 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4737 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4738 & EBINDP(2),EBINDN(2),EPOT(2,210),
4739 & ETACOU(2),ICOUL,LFERMI
4740 * Glauber formalism: flags and parameters for statistics
4743 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4745 * parameters for cascade calculations:
4746 * maximum mumber of PDF's which can be defined in phojet (limited
4747 * by the dimension of ipdfs in pho_setpdf)
4748 PARAMETER (MAXPDF = 20)
4749 * PDF parametrization and number of set for the first 30 hadrons in
4750 * the bamjet-code list
4751 * negative numbers mean that the PDF is set in phojet,
4752 * zero stands for "not a hadron"
4753 DIMENSION IPARPD(30),ISETPD(30)
4754 * PDF parametrization
4756 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4757 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4760 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4761 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4764 C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4765 C PARAMETER ( MAXPRO = 16 )
4766 C PARAMETER ( MAXTAB = 20 )
4767 C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4768 C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4770 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4771 C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4773 C global event kinematics and particle IDs
4775 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4776 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4777 C hard cross sections and MC selection weights
4779 PARAMETER ( Max_pro_2 = 16 )
4780 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4782 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4783 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4784 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4785 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4786 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4787 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4788 C model switches and parameters
4790 INTEGER ISWMDL,IPAMDL
4791 DOUBLE PRECISION PARMDL
4792 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4793 C general process information
4794 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4795 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4797 DIMENSION PP(4),PT(4)
4800 DATA LSTART /.TRUE./
4805 * lepton-projectiles: initialize real photon instead
4806 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4811 IF (LPHOIN) CALL PHO_INIT(-1,IDUM)
4813 * switch Reggeon off
4816 IFPAP(1) = IDT_IPDGHA(IJP)
4820 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4822 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4823 PVIRT(1) = PMASS(1)**2
4825 IFPAP(2) = IDT_IPDGHA(IJT)
4829 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4831 PMASS(2) = AAM(IFPAB(2))
4837 * get max. possible momenta of incoming particles to be used for PHOJET ini.
4841 IF (UMO.GE.1.E5) THEN
4844 IF (NCOMPO.GT.0) THEN
4847 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4849 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4851 PPFTMP = MAX(PFERMP(1),PFERMN(1))
4852 PTFTMP = MAX(PFERMP(2),PFERMN(2))
4853 IF (PPFTMP.GT.PPF) PPF = PPFTMP
4854 IF (PTFTMP.GT.PTF) PTF = PTFTMP
4857 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4858 PPF = MAX(PFERMP(1),PFERMN(1))
4859 PTF = MAX(PFERMP(2),PFERMN(2))
4865 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4867 PP(4) = SQRT(AMP2+PP(3)**2)
4869 EPF = SQRT(PPF**2+PMASS(1)**2)
4870 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4872 ETF = SQRT(PTF**2+PMASS(2)**2)
4873 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4874 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4875 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4877 C *** Commented by Chiara
4878 C WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4880 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
4881 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4882 C *** Commented by Chiara
4883 C IF (NCOMPO.GT.0) THEN
4884 C WRITE(LOUT,1002) SCPF,PTF,PT
4886 C WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4889 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
4890 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4892 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
4893 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4894 C *** Commented by Chiara
4895 C WRITE(LOUT,1004) ECMINI
4896 1004 FORMAT(' E_cm = ',E10.3)
4897 IF (IJP.EQ.8) WRITE(LOUT,1005)
4899 & ' DT_PHOINI: warning! proton parameters used for neutron',
4903 * switch off new diffractive cross sections at low energies for nuclei
4904 * (temporary solution)
4905 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4906 WRITE(LOUT,'(1X,A)')
4907 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4908 CALL PHO_SETMDL(30,0,1)
4911 C IF (IJP.EQ.7) THEN
4912 C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4914 C PP(4) = SQRT(AMP2+PP(3)**2)
4917 C IF (IP.GT.1) PFERMX = 0.5D0
4918 C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4919 C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4922 C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4923 C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4924 C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4927 IF ((ISHAD(2).EQ.1).AND.
4928 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4929 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4932 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4938 * patch for cascade calculations:
4939 * define parton distribution functions for other hadrons, i.e. other
4940 * then defined already in phojet
4941 IF (IOGLB.EQ.100) THEN
4943 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4944 & ' assiged (ID,IPAR,ISET)',/)
4947 IF (IPARPD(I).NE.0) THEN
4949 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4950 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4951 IDPDG = IDT_IPDGHA(I)
4954 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4955 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4961 C CALL PHO_PHIST(-1,SIGMAX)
4963 IF (IREJ1.NE.0) THEN
4965 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
4973 *===eventd=============================================================*
4975 CDECK ID>, DT_EVENTD
4976 SUBROUTINE DT_EVENTD(IREJ)
4978 ************************************************************************
4979 * Quasi-elastic neutrino nucleus scattering. *
4980 * This version dated 29.04.00 is written by S. Roesler. *
4981 ************************************************************************
4983 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4986 PARAMETER ( LINP = 5 ,
4990 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4991 PARAMETER (SQTINF=1.0D+15)
4997 PARAMETER (NMXHKK=200000)
4999 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5000 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5001 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5002 * extended event history
5003 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5004 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5006 * flags for input different options
5007 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5008 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5009 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5011 PARAMETER (MAXLND=4000)
5012 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
5014 * properties of interacting particles
5015 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5016 * Lorentz-parameters of the current interaction
5017 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5018 & UMO,PPCM,EPROJ,PPROJ
5021 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5022 & EBINDP(2),EBINDN(2),EPOT(2,210),
5023 & ETACOU(2),ICOUL,LFERMI
5024 * steering flags for qel neutrino scattering modules
5025 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
5026 COMMON /QNPOL/ POLARX(4),PMODUL
5030 DATA LFIRST /.TRUE./
5042 * interacting target nucleon
5044 IF (NEUDEC.LE.9) THEN
5045 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5053 RTYP = DT_RNDM(RTYP)
5054 ZFRAC = DBLE(ITZ)/DBLE(IT)
5055 IF (RTYP.LE.ZFRAC) THEN
5064 * select first nucleon in list with matching id and reset all other
5065 * nucleons which have been marked as "wounded" by ININUC
5068 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5073 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5077 & STOP ' EVENTD: interacting target nucleon not found! '
5079 * correct position of proj. lepton: assume position of target nucleon
5081 VHKK(I,1) = VHKK(I,IDX)
5082 WHKK(I,1) = WHKK(I,IDX)
5085 * load initial momenta for conservation check
5087 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5088 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5092 * quasi-elastic scattering
5093 IF (NEUDEC.LT.9) THEN
5094 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5095 & PHKK(4,IDX),PHKK(5,IDX))
5096 * CC event on p or n
5097 ELSEIF (NEUDEC.EQ.10) THEN
5098 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5099 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5100 * NC event on p or n
5101 ELSEIF (NEUDEC.EQ.11) THEN
5102 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5103 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5106 * get final state particles from Lund-common and write them into HKKEVT
5114 IF (K(I,1).EQ.1) THEN
5120 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5121 IDBJ = IDT_ICIHAD(ID)
5122 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5123 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5124 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5126 VHKK(1,NHKK) = VHKK(1,IDX)
5127 VHKK(2,NHKK) = VHKK(2,IDX)
5128 VHKK(3,NHKK) = VHKK(3,IDX)
5129 VHKK(4,NHKK) = VHKK(4,IDX)
5131 C WHKK(1,NHKK) = POLARX(1)
5132 C WHKK(2,NHKK) = POLARX(2)
5133 C WHKK(3,NHKK) = POLARX(3)
5134 C WHKK(4,NHKK) = POLARX(4)
5136 WHKK(1,NHKK) = WHKK(1,IDX)
5137 WHKK(2,NHKK) = WHKK(2,IDX)
5138 WHKK(3,NHKK) = WHKK(3,IDX)
5139 WHKK(4,NHKK) = WHKK(4,IDX)
5141 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5147 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5148 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5151 * transform momenta into cms (as required for inc etc.)
5153 IF (ISTHKK(I).EQ.1) THEN
5154 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5163 *===kkevnt=============================================================*
5165 CDECK ID>, DT_KKEVNT
5166 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5168 ************************************************************************
5169 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5170 * without nuclear effects (one event). *
5171 * This subroutine is an update of the previous version (KKEVT) written *
5172 * by J. Ranft/ H.-J. Moehring. *
5173 * This version dated 20.04.95 is written by S. Roesler *
5174 ************************************************************************
5176 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5179 PARAMETER ( LINP = 5 ,
5183 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5185 PARAMETER ( MAXNCL = 260,
5188 & MAXSQU = 20*MAXVQU,
5189 & MAXINT = MAXVQU+MAXSQU)
5192 PARAMETER (NMXHKK=200000)
5194 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5195 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5196 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5197 * extended event history
5198 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5199 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5201 * flags for input different options
5202 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5203 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5204 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5206 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5207 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5208 & IREXCI(3),IRDIFF(2),IRINC
5210 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5211 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5213 * properties of interacting particles
5214 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5215 * Lorentz-parameters of the current interaction
5216 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5217 & UMO,PPCM,EPROJ,PPROJ
5218 * flags for diffractive interactions (DTUNUC 1.x)
5219 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5220 * interface HADRIN-DPM
5221 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5222 * nucleon-nucleon event-generator
5225 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5226 * coordinates of nucleons
5227 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5228 * interface between Glauber formalism and DPM
5229 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5230 & INTER1(MAXINT),INTER2(MAXINT)
5231 * Glauber formalism: collision properties
5232 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5233 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5234 * central particle production, impact parameter biasing
5235 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5237 * statistics: Glauber-formalism
5238 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5241 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5250 IF (MOD(NC,10).EQ.0) THEN
5251 WRITE(LOUT,1000) NEVHKK
5252 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5256 * initialize DTEVT1/DTEVT2
5259 * We need the following only in order to sample nucleon coordinates.
5260 * However we don't have parameters (cross sections, slope etc.)
5261 * for neutrinos available. Therefore switch projectile to proton
5263 IF (MCGENE.EQ.4) THEN
5270 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5271 * make sure that Glauber-formalism is called each time the interaction
5272 * configuration changed
5273 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5274 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5275 * sample number of nucleon-nucleon coll. according to Glauber-form.
5276 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5277 * --- Added by Chiara to monit impact parameter generation
5278 * PRINT *,' Impact parameter generation : b = ', BIMPAC, 'fm'
5289 * force diffractive particle production in h-K interactions
5290 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5291 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5296 * check number of involved proj. nucl. (NP) if central prod.is requested
5297 IF (ICENTR.GT.0) THEN
5298 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5299 IF (IBACK.GT.0) GOTO 10
5302 * get initial nucleon-configuration in projectile and target
5303 * rest-system (including Fermi-momenta if requested)
5304 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5306 IF (EPROJ.LE.EHADTH) MODE = 3
5307 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5309 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5311 * activate HADRIN at low energies (implemented for h-N scattering only)
5312 IF (EPROJ.LE.EHADHI) THEN
5313 IF (EHADTH.LT.ZERO) THEN
5314 * smooth transition btwn. DPM and HADRIN
5315 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5317 IF (RR.GT.FRAC) THEN
5319 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5320 IF (IREJ1.GT.0) GOTO 1
5323 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5327 * fixed threshold for onset of production via HADRIN
5328 IF (EPROJ.LE.EHADTH) THEN
5330 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5331 IF (IREJ1.GT.0) GOTO 1
5334 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5339 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5340 & I3,') with target (m=',I3,')',/,11X,
5341 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5342 & 'GeV) cannot be handled')
5344 * sampling of momentum-x fractions & flavors of chain ends
5347 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5350 * collect momenta of chain ends and put them into DTEVT1
5351 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5352 IF (IREJ1.NE.0) GOTO 1
5356 * handle chains including fragmentation (two-chain approximation)
5357 IF (MCGENE.EQ.1) THEN
5358 * two-chain approximation
5359 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5360 IF (IREJ1.NE.0) THEN
5361 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5364 ELSEIF (MCGENE.EQ.2) THEN
5365 * multiple-Po exchange including minijets
5366 CALL DT_EVENTB(NCSY,IREJ1)
5367 IF (IREJ1.NE.0) THEN
5368 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5371 ELSEIF (MCGENE.EQ.3) THEN
5373 STOP ' This version does not contain LEPTO !'
5375 ELSEIF (MCGENE.EQ.4) THEN
5376 * quasi-elastic neutrino scattering
5377 CALL DT_EVENTD(IREJ1)
5378 IF (IREJ1.NE.0) THEN
5379 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5383 WRITE(LOUT,1002) MCGENE
5384 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5385 & ' not available - program stopped')
5396 *===chkcen=============================================================*
5398 CDECK ID>, DT_CHKCEN
5399 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5401 ************************************************************************
5402 * Check of number of involved projectile nucleons if central production*
5404 * Adopted from a part of the old KKEVT routine which was written by *
5405 * J. Ranft/H.-J.Moehring. *
5406 * This version dated 13.01.95 is written by S. Roesler *
5407 ************************************************************************
5409 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5412 PARAMETER ( LINP = 5 ,
5417 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5418 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5420 * central particle production, impact parameter biasing
5421 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5426 IF (ICENTR.EQ.2) THEN
5429 IF (NP.LT.IP-1) IBACK = 1
5430 ELSEIF (IP.LE.16) THEN
5431 IF (NP.LT.IP-2) IBACK = 1
5432 ELSEIF (IP.LE.32) THEN
5433 IF (NP.LT.IP-3) IBACK = 1
5434 ELSEIF (IP.GE.33) THEN
5435 IF (NP.LT.IP-5) IBACK = 1
5437 ELSEIF (IP.EQ.IT) THEN
5439 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5441 IF (NP.LT.IP-IP/8) IBACK = 1
5443 ELSEIF (ABS(IP-IT).LT.3) THEN
5444 IF (NP.LT.IP-IP/8) IBACK = 1
5447 * new version (DPMJET, 5.6.99)
5450 IF (NP.LT.IP-1) IBACK = 1
5451 ELSEIF (IP.LE.16) THEN
5452 IF (NP.LT.IP-2) IBACK = 1
5453 ELSEIF (IP.LT.32) THEN
5454 IF (NP.LT.IP-3) IBACK = 1
5455 ELSEIF (IP.GE.32) THEN
5458 IF (NP.LT.IP-1) IBACK = 1
5461 IF (NP.LT.IP) IBACK = 1
5464 ELSEIF (IP.EQ.IT) THEN
5467 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5470 IF (NP.LT.IP-IP/4) IBACK = 1
5472 ELSEIF (ABS(IP-IT).LT.3) THEN
5473 IF (NP.LT.IP-IP/8) IBACK = 1
5482 *===ininuc=============================================================*
5484 CDECK ID>, DT_ININUC
5485 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5487 ************************************************************************
5488 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5489 * including Fermi-momenta (if reqested). *
5490 * ID BAMJET-code for hadrons (instead of nuclei) *
5491 * NMASS mass number of nucleus (number of nucleons) *
5492 * NCH charge of nucleus *
5493 * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5494 * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5495 * IMODE = 1 projectile nucleus *
5496 * = 2 target nucleus *
5497 * = 3 target nucleus (E_lab<E_thr for HADRIN) *
5498 * Adopted from a part of the old KKEVT routine which was written by *
5499 * J. Ranft/H.-J.Moehring. *
5500 * This version dated 13.01.95 is written by S. Roesler *
5501 ************************************************************************
5503 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5506 PARAMETER ( LINP = 5 ,
5510 PARAMETER (FM2MM=1.0D-12)
5512 PARAMETER ( MAXNCL = 260,
5515 & MAXSQU = 20*MAXVQU,
5516 & MAXINT = MAXVQU+MAXSQU)
5519 PARAMETER (NMXHKK=200000)
5521 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5522 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5523 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5524 * extended event history
5525 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5526 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5528 * flags for input different options
5529 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5530 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5531 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5532 * auxiliary common for chain system storage (DTUNUC 1.x)
5533 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5536 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5537 & EBINDP(2),EBINDN(2),EPOT(2,210),
5538 & ETACOU(2),ICOUL,LFERMI
5539 * properties of photon/lepton projectiles
5540 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5541 * particle properties (BAMJET index convention)
5543 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5544 & IICH(210),IIBAR(210),K1(210),K2(210)
5545 * Glauber formalism: collision properties
5546 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5547 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5548 * flavors of partons (DTUNUC 1.x)
5549 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5550 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5551 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5552 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5553 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5554 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5555 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5556 * interface HADRIN-DPM
5557 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5559 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5561 * number of neutrons
5570 IF (IMODE.GT.2) MODE = 2
5571 **sr 29.5. new NPOINT(1)-definition
5572 C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5577 * get initial configuration
5580 IF (JS(I).GT.0) THEN
5581 ISTHKK(NHKK) = 10+MODE
5582 IF (IMODE.EQ.3) THEN
5583 * additional treatment if HADRIN-generator is requested
5585 IF (NHADRI.EQ.1) IDXTA = NHKK
5586 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5589 ISTHKK(NHKK) = 12+MODE
5591 IF (NMASS.GE.2) THEN
5592 * treatment for nuclei
5593 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5595 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5598 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5601 ELSEIF (NN.LT.NNEU) THEN
5604 ELSEIF (NP.LT.NCH) THEN
5608 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5619 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5622 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5624 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5626 PFTOT(K) = PFTOT(K)+PF(K)
5627 PHKK(K,NHKK) = PF(K)
5629 PHKK(5,NHKK) = AAM(IDX)
5631 * treatment for hadrons
5632 IDHKK(NHKK) = IDT_IPDGHA(ID)
5634 PHKK(4,NHKK) = AAM(ID)
5635 PHKK(5,NHKK) = AAM(ID)
5637 C IF (IDHKK(NHKK).EQ.22) THEN
5638 C PHKK(4,NHKK) = AAM(33)
5639 C PHKK(5,NHKK) = AAM(33)
5644 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5651 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5652 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5654 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5655 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5656 VHKK(4,NHKK) = 0.0D0
5657 WHKK(4,NHKK) = 0.0D0
5660 * balance Fermi-momenta
5661 IF (NMASS.GE.2) THEN
5665 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5667 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5668 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5675 *===fer4m==============================================================*
5678 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5680 ************************************************************************
5681 * Sampling of nucleon Fermi-momenta from distributions at T=0. *
5682 * processed by S. Roesler, 17.10.95 *
5683 ************************************************************************
5685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5688 PARAMETER ( LINP = 5 ,
5694 * particle properties (BAMJET index convention)
5696 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5697 & IICH(210),IIBAR(210),K1(210),K2(210)
5700 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5701 & EBINDP(2),EBINDN(2),EPOT(2,210),
5702 & ETACOU(2),ICOUL,LFERMI
5704 DATA LSTART /.TRUE./
5710 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
5714 CALL DT_DFERMI(PABS)
5716 C IF (PABS.GE.PBIND) THEN
5718 C IF (MOD(ILOOP,500).EQ.0) THEN
5719 C WRITE(LOUT,1001) PABS,PBIND,ILOOP
5720 C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
5721 C & ' energy ',2E12.3,I6)
5725 CALL DT_DPOLI(POLC,POLS)
5726 CALL DT_DSFECF(SFE,CFE)
5730 ET = SQRT(PABS*PABS+AAM(KT)**2)
5744 *===nuc2cm=============================================================*
5746 CDECK ID>, DT_NUC2CM
5747 SUBROUTINE DT_NUC2CM
5749 ************************************************************************
5750 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
5751 * nucl. cms. (This subroutine replaces NUCMOM.) *
5752 * This version dated 15.01.95 is written by S. Roesler *
5753 ************************************************************************
5755 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5758 PARAMETER ( LINP = 5 ,
5762 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5766 PARAMETER (NMXHKK=200000)
5768 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5769 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5770 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5771 * extended event history
5772 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5773 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5776 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5777 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5779 * properties of photon/lepton projectiles
5780 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5781 * particle properties (BAMJET index convention)
5783 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5784 & IICH(210),IIBAR(210),K1(210),K2(210)
5785 * Glauber formalism: collision properties
5786 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5787 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5789 * statistics: Glauber-formalism
5790 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5802 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5803 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5804 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5806 C IF (IDHKK(I).EQ.22) THEN
5814 C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5815 C & PX,PY,PZ,PE,IDB,MODE)
5816 IF (PHKK(5,I).GT.ZERO) THEN
5817 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5818 & PX,PY,PZ,PE,IDBAM(I),MODE)
5828 C IF (ID.EQ.22) ID = 113
5829 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5830 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5831 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5835 NWTACC = MAX(NWAACC,NWBACC)
5839 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5847 *===splptn=============================================================*
5849 CDECK ID>, DT_SPLPTN
5850 SUBROUTINE DT_SPLPTN(NN)
5852 ************************************************************************
5853 * SamPLing of ParToN momenta and flavors. *
5854 * This version dated 15.01.95 is written by S. Roesler *
5855 ************************************************************************
5857 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5860 PARAMETER ( LINP = 5 ,
5864 * Lorentz-parameters of the current interaction
5865 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5866 & UMO,PPCM,EPROJ,PPROJ
5868 * sample flavors of sea-quarks
5869 CALL DT_SPLFLA(NN,1)
5871 * sample x-values of partons at chain ends
5873 CALL DT_XKSAMP(NN,ECM)
5876 CALL DT_SPLFLA(NN,2)
5881 *===splfla=============================================================*
5883 CDECK ID>, DT_SPLFLA
5884 SUBROUTINE DT_SPLFLA(NN,MODE)
5886 ************************************************************************
5887 * SamPLing of FLAvors of partons at chain ends. *
5888 * This subroutine replaces FLKSAA/FLKSAM. *
5889 * NN number of nucleon-nucleon interactions *
5890 * MODE = 1 sea-flavors *
5891 * = 2 valence-flavors *
5892 * Based on the original version written by J. Ranft/H.-J. Moehring. *
5893 * This version dated 16.01.95 is written by S. Roesler *
5894 ************************************************************************
5896 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5899 PARAMETER ( LINP = 5 ,
5903 PARAMETER ( MAXNCL = 260,
5906 & MAXSQU = 20*MAXVQU,
5907 & MAXINT = MAXVQU+MAXSQU)
5908 * flavors of partons (DTUNUC 1.x)
5909 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5910 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5911 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5912 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5913 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5914 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5915 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5916 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5917 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5918 & IXPV,IXPS,IXTV,IXTS,
5919 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5920 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5921 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5922 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5923 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5924 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5925 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5926 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5927 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5928 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5929 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5930 * particle properties (BAMJET index convention)
5932 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5933 & IICH(210),IIBAR(210),K1(210),K2(210)
5934 * various options for treatment of partons (DTUNUC 1.x)
5935 * (chain recombination, Cronin,..)
5936 LOGICAL LCO2CR,LINTPT
5937 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5943 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5947 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5950 ELSEIF (MODE.EQ.2) THEN
5953 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5956 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5963 *===getptn=============================================================*
5965 CDECK ID>, DT_GETPTN
5966 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5968 ************************************************************************
5969 * This subroutine collects partons at chain ends from temporary *
5970 * commons and puts them into DTEVT1. *
5971 * This version dated 15.01.95 is written by S. Roesler *
5972 ************************************************************************
5974 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5977 PARAMETER ( LINP = 5 ,
5981 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5985 PARAMETER ( MAXNCL = 260,
5988 & MAXSQU = 20*MAXVQU,
5989 & MAXINT = MAXVQU+MAXSQU)
5992 PARAMETER (NMXHKK=200000)
5994 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5995 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5996 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5997 * extended event history
5998 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5999 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6001 * flags for input different options
6002 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6003 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6004 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6005 * auxiliary common for chain system storage (DTUNUC 1.x)
6006 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6008 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6009 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6011 * flags for diffractive interactions (DTUNUC 1.x)
6012 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6013 * x-values of partons (DTUNUC 1.x)
6014 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6015 & XTVQ(MAXVQU),XTVD(MAXVQU),
6016 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
6017 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
6018 * flavors of partons (DTUNUC 1.x)
6019 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6020 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6021 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6022 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6023 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6024 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6025 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6026 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6027 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6028 & IXPV,IXPS,IXTV,IXTS,
6029 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6030 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6031 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6032 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6033 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6034 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6035 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6036 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6037 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6038 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6039 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6041 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6043 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6051 IF (ISKPCH(1,I).EQ.99) GOTO 10
6052 ICCHAI(1,1) = ICCHAI(1,1)+2
6055 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6056 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6058 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6059 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6060 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6061 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6063 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6064 & +(PP1(3)+PT1(3))**2)
6066 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6067 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6068 & +(PP2(3)+PT2(3))**2)
6070 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6071 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6074 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6075 C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6076 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6079 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6081 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6082 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6083 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6084 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6085 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6087 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6089 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6091 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6098 IF (ISKPCH(2,I).EQ.99) GOTO 20
6099 ICCHAI(1,2) = ICCHAI(1,2)+2
6102 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6103 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6105 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6106 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6107 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6108 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6110 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6111 & +(PP1(3)+PT1(3))**2)
6113 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6114 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6115 & +(PP2(3)+PT2(3))**2)
6117 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6118 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6121 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6122 C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6123 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6126 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6128 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6129 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6130 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6131 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6132 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6134 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6136 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6138 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6145 IF (ISKPCH(3,I).EQ.99) GOTO 30
6146 ICCHAI(1,3) = ICCHAI(1,3)+2
6149 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6150 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6152 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6153 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6154 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6155 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6157 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6158 & +(PP1(3)+PT1(3))**2)
6160 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6161 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6162 & +(PP2(3)+PT2(3))**2)
6164 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6165 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6168 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6169 C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6170 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6173 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6175 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6176 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6177 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6178 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6179 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6181 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6183 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6185 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6190 * disea-valence chains
6192 IF (ISKPCH(5,I).EQ.99) GOTO 50
6193 ICCHAI(1,5) = ICCHAI(1,5)+2
6196 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6197 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6199 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6200 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6201 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6202 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6204 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6205 & +(PP1(3)+PT1(3))**2)
6207 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6208 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6209 & +(PP2(3)+PT2(3))**2)
6211 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6212 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6215 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6216 C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6217 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6220 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6222 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6223 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6224 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6225 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6226 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6228 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6230 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6232 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6237 * valence-sea chains
6239 IF (ISKPCH(6,I).EQ.99) GOTO 60
6240 ICCHAI(1,6) = ICCHAI(1,6)+2
6243 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6244 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6246 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6247 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6248 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6249 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6251 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6252 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6253 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6254 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6255 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6257 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6259 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6261 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6263 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6265 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6266 & +(PP1(3)+PT1(3))**2)
6268 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6269 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6270 & +(PP2(3)+PT2(3))**2)
6272 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6274 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6276 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6278 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6280 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6282 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6283 & +(PP1(3)+PT2(3))**2)
6285 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6286 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6287 & +(PP2(3)+PT1(3))**2)
6289 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6291 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6294 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6295 C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6296 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6299 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6304 * sea-valence chains
6306 IF (ISKPCH(4,I).EQ.99) GOTO 40
6307 ICCHAI(1,4) = ICCHAI(1,4)+2
6310 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6311 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6313 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6314 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6315 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6316 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6318 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6319 & +(PP1(3)+PT1(3))**2)
6321 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6322 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6323 & +(PP2(3)+PT2(3))**2)
6325 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6326 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6329 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6330 C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6331 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6334 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6336 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6337 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6338 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6339 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6340 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6342 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6344 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6346 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6351 * valence-disea chains
6353 IF (ISKPCH(7,I).EQ.99) GOTO 70
6354 ICCHAI(1,7) = ICCHAI(1,7)+2
6357 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6358 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6360 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6361 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6362 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6363 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6365 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6366 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6367 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6368 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6369 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6371 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6373 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6375 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6377 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6379 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6380 & +(PP1(3)+PT1(3))**2)
6382 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6383 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6384 & +(PP2(3)+PT2(3))**2)
6386 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6388 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6390 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6392 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6394 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6396 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6397 & +(PP1(3)+PT2(3))**2)
6399 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6400 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6401 & +(PP2(3)+PT1(3))**2)
6403 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6405 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6408 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6409 C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6410 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6413 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6418 * valence-valence chains
6420 IF (ISKPCH(8,I).EQ.99) GOTO 80
6421 ICCHAI(1,8) = ICCHAI(1,8)+2
6424 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6425 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6427 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6428 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6429 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6430 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6432 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6433 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6434 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6435 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6437 * check for diffractive event
6439 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6440 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6442 PP(K) = PP1(K)+PP2(K)
6443 PT(K) = PT1(K)+PT2(K)
6446 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6447 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6448 C IF (IREJ1.NE.0) GOTO 9999
6449 IF (IREJ1.NE.0) THEN
6457 IF (IDIFF.EQ.0) THEN
6458 * valence-valence chain system
6459 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6462 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6463 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6464 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6465 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6466 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6467 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6468 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6469 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6470 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6471 & +(PP1(3)+PT1(3))**2)
6473 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6474 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6475 & +(PP2(3)+PT2(3))**2)
6477 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6480 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6481 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6482 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6483 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6484 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6485 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6486 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6487 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6488 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6489 & +(PP1(3)+PT2(3))**2)
6491 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6492 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6493 & +(PP2(3)+PT1(3))**2)
6495 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6497 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6500 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6501 C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6502 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6505 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6510 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6512 * energy-momentum & flavor conservation check
6513 IF (ABS(IDIFF).NE.1) THEN
6514 IF (IDIFF.NE.0) THEN
6515 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6518 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6534 *===chkcsy=============================================================*
6536 CDECK ID>, DT_CHKCSY
6537 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6539 ************************************************************************
6540 * CHeCk Chain SYstem for consistency of partons at chain ends. *
6541 * ID1,ID2 PDG-numbers of partons at chain ends *
6542 * LCHK = .true. consistent chain *
6543 * = .false. inconsistent chain *
6544 * This version dated 18.01.95 is written by S. Roesler *
6545 ************************************************************************
6547 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6550 PARAMETER ( LINP = 5 ,
6559 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6560 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6561 * q-qq, aq-aqaq chain
6562 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6563 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6564 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6566 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6567 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6573 *===eventa=============================================================*
6575 CDECK ID>, DT_EVENTA
6576 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6578 ************************************************************************
6579 * Treatment of nucleon-nucleon interactions in a two-chain *
6581 * (input) ID BAMJET-index of projectile hadron (in case of *
6583 * IP/IT mass number of projectile/target nucleus *
6584 * NCSY number of two chain systems *
6585 * IREJ rejection flag *
6586 * This version dated 15.01.95 is written by S. Roesler *
6587 ************************************************************************
6589 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6592 PARAMETER ( LINP = 5 ,
6596 PARAMETER (TINY10=1.0D-10)
6600 PARAMETER (NMXHKK=200000)
6602 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6603 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6604 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6605 * extended event history
6606 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6607 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6610 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6611 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6612 & IREXCI(3),IRDIFF(2),IRINC
6613 * flags for diffractive interactions (DTUNUC 1.x)
6614 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6615 * particle properties (BAMJET index convention)
6617 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6618 & IICH(210),IIBAR(210),K1(210),K2(210)
6619 * flags for input different options
6620 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6621 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6622 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6623 * various options for treatment of partons (DTUNUC 1.x)
6624 * (chain recombination, Cronin,..)
6625 LOGICAL LCO2CR,LINTPT
6626 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6629 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6634 * skip following treatment for low-mass diffraction
6635 IF (ABS(IFLAGD).EQ.1) THEN
6636 NPOINT(3) = NPOINT(2)
6640 * multiple scattering of chain ends
6641 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6642 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6645 * get a two-chain system from DTEVT1
6653 PT1(K) = PHKK(K,NC+1)
6654 PP2(K) = PHKK(K,NC+2)
6655 PT2(K) = PHKK(K,NC+3)
6661 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6662 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6663 IF (IREJ1.GT.0) THEN
6665 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6671 * meson/antibaryon projectile:
6672 * sample single-chain valence-valence systems (Reggeon contrib.)
6673 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6674 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6677 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6678 * check DTEVT1 for remaining resonance mass corrections
6679 CALL DT_EVTRES(IREJ1)
6680 IF (IREJ1.GT.0) THEN
6681 IRRES(1) = IRRES(1)+1
6682 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6687 * assign p_t to two-"chain" systems consisting of two resonances only
6688 * since only entries for chains will be affected, this is obsolete
6689 * in case of JETSET-fragmetation
6692 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6693 IF (LCO2CR) CALL DT_COM2CR
6697 * fragmentation of the complete event
6698 **uncomment for internal phojet-fragmentation
6699 C CALL DT_EVTFRA(IREJ1)
6700 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6701 IF (IREJ1.GT.0) THEN
6703 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6707 * decay of possible resonances (should be obsolete)
6718 *===getcsy=============================================================*
6720 CDECK ID>, DT_GETCSY
6721 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6722 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6724 ************************************************************************
6725 * This version dated 15.01.95 is written by S. Roesler *
6726 ************************************************************************
6728 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6731 PARAMETER ( LINP = 5 ,
6735 PARAMETER (TINY10=1.0D-10)
6739 PARAMETER (NMXHKK=200000)
6741 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6742 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6743 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6744 * extended event history
6745 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6746 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6749 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6750 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6751 & IREXCI(3),IRDIFF(2),IRINC
6752 * flags for input different options
6753 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6754 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6755 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6756 * flags for diffractive interactions (DTUNUC 1.x)
6757 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6759 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6760 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6764 * get quark content of partons
6771 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6772 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6773 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6774 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6775 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6776 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6777 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6778 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6780 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6782 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6783 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6785 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6786 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6788 * store initial configuration for energy-momentum cons. check
6789 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6791 * sample intrinsic p_t at chain-ends
6792 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6793 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6794 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6795 IF (IREJ1.NE.0) THEN
6796 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6801 C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6802 C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6803 C* check second chain for resonance
6804 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6805 C & AMCH2,AMCH2N,IDCH2,IREJ1)
6806 C IF (IREJ1.NE.0) GOTO 9999
6807 C IF (IDR2.NE.0) THEN
6808 C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6809 C & AMCH2,AMCH2N,AMCH1,IREJ1)
6810 C IF (IREJ1.NE.0) GOTO 9999
6812 C* check first chain for resonance
6813 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6814 C & AMCH1,AMCH1N,IDCH1,IREJ1)
6815 C IF (IREJ1.NE.0) GOTO 9999
6816 C IF (IDR1.NE.0) IDR1 = 100*IDR1
6818 C* check first chain for resonance
6819 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6820 C & AMCH1,AMCH1N,IDCH1,IREJ1)
6821 C IF (IREJ1.NE.0) GOTO 9999
6822 C IF (IDR1.NE.0) THEN
6823 C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6824 C & AMCH1,AMCH1N,AMCH2,IREJ1)
6825 C IF (IREJ1.NE.0) GOTO 9999
6827 C* check second chain for resonance
6828 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6829 C & AMCH2,AMCH2N,IDCH2,IREJ1)
6830 C IF (IREJ1.NE.0) GOTO 9999
6831 C IF (IDR2.NE.0) IDR2 = 100*IDR2
6835 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6836 * check chains for resonances
6837 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6838 & AMCH1,AMCH1N,IDCH1,IREJ1)
6839 IF (IREJ1.NE.0) GOTO 9999
6840 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6841 & AMCH2,AMCH2N,IDCH2,IREJ1)
6842 IF (IREJ1.NE.0) GOTO 9999
6843 * change kinematics corresponding to resonance-masses
6844 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6845 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6846 & AMCH1,AMCH1N,AMCH2,IREJ1)
6847 IF (IREJ1.GT.0) GOTO 9999
6848 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6849 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6850 & AMCH2,AMCH2N,IDCH2,IREJ1)
6851 IF (IREJ1.NE.0) GOTO 9999
6852 IF (IDR2.NE.0) IDR2 = 100*IDR2
6853 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6854 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6855 & AMCH2,AMCH2N,AMCH1,IREJ1)
6856 IF (IREJ1.GT.0) GOTO 9999
6857 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6858 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6859 & AMCH1,AMCH1N,IDCH1,IREJ1)
6860 IF (IREJ1.NE.0) GOTO 9999
6861 IF (IDR1.NE.0) IDR1 = 100*IDR1
6862 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6863 AMDIF1 = ABS(AMCH1-AMCH1N)
6864 AMDIF2 = ABS(AMCH2-AMCH2N)
6865 IF (AMDIF2.LT.AMDIF1) THEN
6866 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6867 & AMCH2,AMCH2N,AMCH1,IREJ1)
6868 IF (IREJ1.GT.0) GOTO 9999
6869 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6870 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6871 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6872 IF (IREJ1.NE.0) GOTO 9999
6873 IF (IDR1.NE.0) IDR1 = 100*IDR1
6875 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6876 & AMCH1,AMCH1N,AMCH2,IREJ1)
6877 IF (IREJ1.GT.0) GOTO 9999
6878 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6879 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6880 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6881 IF (IREJ1.NE.0) GOTO 9999
6882 IF (IDR2.NE.0) IDR2 = 100*IDR2
6887 * store final configuration for energy-momentum cons. check
6889 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6890 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6891 IF (IREJ1.NE.0) GOTO 9999
6894 * put partons and chains into DTEVT1
6896 PCH1(I) = PP1(I)+PT1(I)
6897 PCH2(I) = PP2(I)+PT2(I)
6899 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6900 & PP1(3),PP1(4),0,0,0)
6901 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6902 & PT1(3),PT1(4),0,0,0)
6903 KCH = 100+IDCH(MOP1)*10+1
6904 CALL DT_EVTPUT(KCH,88888,-2,-1,
6905 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6906 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6907 & PP2(3),PP2(4),0,0,0)
6908 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6909 & PT2(3),PT2(4),0,0,0)
6911 CALL DT_EVTPUT(KCH,88888,-2,-1,
6912 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6917 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6918 * "cancel" sea-sea chains
6919 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6920 IF (IREJ1.NE.0) GOTO 9998
6921 **sr 16.5. flag for EVENTB
6930 *===chkine=============================================================*
6932 CDECK ID>, DT_CHKINE
6933 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6934 & AMCH1,AMCH1N,AMCH2,IREJ)
6936 ************************************************************************
6937 * This subroutine replaces CORMOM. *
6938 * This version dated 05.01.95 is written by S. Roesler *
6939 ************************************************************************
6941 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6944 PARAMETER ( LINP = 5 ,
6948 PARAMETER (TINY10=1.0D-10)
6950 * flags for input different options
6951 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6952 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6953 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6955 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6956 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6957 & IREXCI(3),IRDIFF(2),IRINC
6959 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6960 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6965 SCALE = AMCH1N/MAX(AMCH1,TINY10)
6971 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6972 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6973 PP1(I) = SCALE*PP1(I)
6974 PT1(I) = SCALE*PT1(I)
6976 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6977 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6980 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6981 & (PP2(3)+PT2(3))**2 )
6982 AMCH22 = (ECH-PCH)*(ECH+PCH)
6983 IF (AMCH22.LT.0.0D0) THEN
6985 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6990 AMCH2 = SQRT(AMCH22)
6992 * put partons again on mass shell
6996 IF (JMSHL.EQ.1) THEN
7002 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7003 IF (IREJ1.NE.0) THEN
7004 IF (JMSHL.EQ.0) GOTO 9998
7016 IF (JMSHL.EQ.1) THEN
7022 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7023 IF (IREJ1.NE.0) THEN
7024 IF (JMSHL.EQ.0) GOTO 9998
7040 9997 IRCHKI(1) = IRCHKI(1)+1
7046 9998 IRCHKI(2) = IRCHKI(2)+1
7049 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7054 *===ch2res=============================================================*
7056 CDECK ID>, DT_CH2RES
7057 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7058 & AM,AMN,IMODE,IREJ)
7060 ************************************************************************
7061 * Check chains for resonance production. *
7062 * This subroutine replaces COMCMA/COBCMA/COMCM2 *
7064 * IF1,2,3,4 input flavors (q,aq in any order) *
7066 * MODE = 1 check q-aq chain for meson-resonance *
7067 * = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7068 * = 3 check qq-aqaq chain for lower mass cut *
7070 * IDR = 0 no resonances found *
7071 * = -1 pseudoscalar meson/octet baryon *
7072 * = 1 vector-meson/decuplet baryon *
7073 * IDXR BAMJET-index of corresponding resonance *
7074 * AMN mass of corresponding resonance *
7076 * IREJ rejection flag *
7077 * This version dated 06.01.95 is written by S. Roesler *
7078 ************************************************************************
7080 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7083 PARAMETER ( LINP = 5 ,
7087 * particle properties (BAMJET index convention)
7089 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7090 & IICH(210),IIBAR(210),K1(210),K2(210)
7091 * quark-content to particle index conversion (DTUNUC 1.x)
7092 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7093 & IA08(6,21),IA10(6,21)
7095 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7096 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7097 & IREXCI(3),IRDIFF(2),IRINC
7098 * flags for input different options
7099 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7100 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7101 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7103 DIMENSION IF(4),JF(4)
7106 C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7107 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7109 C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7113 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7114 WRITE(LOUT,1000) MODE
7115 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7116 & 1X,' program stopped')
7125 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7126 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7134 IF (IF(I).NE.0) THEN
7139 IF (NF.LE.MODE) THEN
7140 WRITE(LOUT,1001) MODE,IF
7141 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7142 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7148 * check for meson resonance
7152 IF (JF(2).GT.0) THEN
7156 IFPS = IMPS(IFAQ,IFQ)
7157 IFV = IMVE(IFAQ,IFQ)
7161 IF (AMX.LT.AMV) THEN
7162 IF (AMX.LT.AMPS) THEN
7163 IF (IMODE.GT.0) THEN
7164 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7166 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7170 * replace chain by pseudoscalar meson
7174 ELSEIF (AMX.LT.AMHI) THEN
7175 * replace chain by vector-meson
7182 * check for baryon resonance
7184 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7188 IF (AMX.LT.AM10) THEN
7189 IF (AMX.LT.AM8) THEN
7190 IF (IMODE.GT.0) THEN
7191 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7193 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7197 * replace chain by oktet baryon
7201 ELSEIF (AMX.LT.AMHI) THEN
7208 * check qq-aqaq for lower mass cut
7210 * empirical definition of AMHI to allow for (b-antib)-pair prod.
7212 IF (AMX.LT.AMHI) GOTO 9999
7216 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7217 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7219 IRRES(2) = IRRES(2)+1
7223 *===rjseac=============================================================*
7225 CDECK ID>, DT_RJSEAC
7226 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7228 ************************************************************************
7229 * ReJection of SEA-sea Chains. *
7230 * MOP1/2 entries of projectile sea-partons in DTEVT1 *
7231 * MOT1/2 entries of projectile sea-partons in DTEVT1 *
7232 * This version dated 16.01.95 is written by S. Roesler *
7233 ************************************************************************
7235 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7238 PARAMETER ( LINP = 5 ,
7242 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7246 PARAMETER (NMXHKK=200000)
7248 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7249 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7250 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7251 * extended event history
7252 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7253 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7256 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7257 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7260 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7264 * projectile sea q-aq-pair
7265 * indices of sea-pair
7268 * index of mother-nucleon
7269 IDXNUC(1) = JMOHKK(1,MOP1)
7270 * status of valence quarks to be corrected
7273 * target sea q-aq-pair
7274 * indices of sea-pair
7277 * index of mother-nucleon
7278 IDXNUC(2) = JMOHKK(1,MOT1)
7279 * status of valence quarks to be corrected
7284 DO 2 I=NPOINT(2),NHKK
7285 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7286 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7287 * valence parton found
7288 * inrease 4-momentum by sea 4-momentum
7290 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7291 & PHKK(K,IDXSEA(N,2))
7293 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7294 & PHKK(2,I)**2-PHKK(3,I)**2))
7297 ISTHKK(IDXSEA(N,J)) = 100
7298 IDHKK(IDXSEA(N,J)) = 0
7299 JMOHKK(1,IDXSEA(N,J)) = 0
7300 JMOHKK(2,IDXSEA(N,J)) = 0
7301 JDAHKK(1,IDXSEA(N,J)) = 0
7302 JDAHKK(2,IDXSEA(N,J)) = 0
7304 PHKK(K,IDXSEA(N,J)) = ZERO
7305 VHKK(K,IDXSEA(N,J)) = ZERO
7306 WHKK(K,IDXSEA(N,J)) = ZERO
7308 PHKK(5,IDXSEA(N,J)) = ZERO
7313 IF (IDONE.NE.1) THEN
7314 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7315 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7316 & '-record!',/,1X,' sea-quark pairs ',
7317 & 2I5,4X,2I5,' could not be canceled!')
7329 *===vv2sch=============================================================*
7331 CDECK ID>, DT_VV2SCH
7332 SUBROUTINE DT_VV2SCH
7334 ************************************************************************
7335 * Change Valence-Valence chain systems to Single CHain systems for *
7336 * hadron-nucleus collisions with meson or antibaryon projectile. *
7337 * (Reggeon contribution) *
7338 * The single chain system is approximately treated as one chain and a *
7340 * This version dated 18.01.95 is written by S. Roesler *
7341 ************************************************************************
7343 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7346 PARAMETER ( LINP = 5 ,
7350 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7356 PARAMETER (NMXHKK=200000)
7358 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7359 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7360 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7361 * extended event history
7362 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7363 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7365 * flags for input different options
7366 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7367 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7368 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7370 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7371 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7374 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7377 DATA LSTART /.TRUE./
7382 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7383 & 'valence chains treated')
7389 * get index of first chain
7390 DO 1 I=NPOINT(3),NHKK
7391 IF (IDHKK(I).EQ.88888) THEN
7398 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7399 & .AND.(NC.LT.NSTOP)) THEN
7400 * get valence-valence chains
7401 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7402 * get "mother"-hadron indices
7403 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7404 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7405 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7406 KTARG = IDT_ICIHAD(IDHKK(MO2))
7407 * Lab momentum of projectile hadron
7408 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7409 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7412 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7413 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7415 * single chain requested
7416 * get flavors of chain-end partons
7417 MO(1) = JMOHKK(1,NC)
7418 MO(2) = JMOHKK(2,NC)
7419 MO(3) = JMOHKK(1,NC+3)
7420 MO(4) = JMOHKK(2,NC+3)
7422 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7424 IF (ABS(IDHKK(MO(I))).GE.1000)
7425 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7427 * which one is the q-aq chain?
7428 * N1,N1+1 - DTEVT1-entries for q-aq system
7429 * N2,N2+1 - DTEVT1-entries for the other chain
7430 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7435 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7445 PT1(K) = PHKK(K,N1+1)
7447 PT2(K) = PHKK(K,N2+1)
7449 AMCH1 = PHKK(5,N1+2)
7450 AMCH2 = PHKK(5,N2+2)
7451 * get meson-identity corresponding to flavors of q-aq chain
7454 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7455 & ZERO,AMCH1N,1,IDUM)
7457 * change kinematics of chains
7458 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7459 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7460 & AMCH1,AMCH1N,AMCH2,IREJ1)
7461 IF (IREJ1.NE.0) GOTO 10
7462 * check second chain for resonance
7464 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7465 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7466 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7467 IF (IREJ1.NE.0) GOTO 10
7468 IF (IDR2.NE.0) IDR2 = 100*IDR2
7469 * add partons and chains to DTEVT1
7471 PCH1(K) = PP1(K)+PT1(K)
7472 PCH2(K) = PP2(K)+PT2(K)
7474 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7475 & PP1(3),PP1(4),0,0,0)
7476 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7477 & PT1(2),PT1(3),PT1(4),0,0,0)
7478 KCH = ISTHKK(N1+2)+100
7479 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7480 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7482 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7483 & PP2(3),PP2(4),0,0,0)
7484 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7485 & PT2(2),PT2(3),PT2(4),0,0,0)
7486 KCH = ISTHKK(N2+2)+100
7487 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7488 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7504 *=== phnsch ===========================================================*
7506 CDECK ID>, DT_PHNSCH
7507 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7509 *----------------------------------------------------------------------*
7511 * Probability for Hadron Nucleon Single CHain interactions: *
7513 * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7516 * Last change on 04-jan-94 by Alfredo Ferrari *
7518 * modified by J.R.for use in DTUNUC 6.1.94 *
7520 * Input variables: *
7521 * Kp = hadron projectile index (Part numbering *
7523 * Ktarg = target nucleon index (1=proton, 8=neutron) *
7524 * Plab = projectile laboratory momentum (GeV/c) *
7525 * Output variable: *
7526 * Phnsch = probability per single chain (particle *
7527 * exchange) interactions *
7529 *----------------------------------------------------------------------*
7531 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7534 PARAMETER ( LUNOUT = 6 )
7535 PARAMETER ( LUNERR = 6 )
7536 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7537 PARAMETER ( ZERZER = 0.D+00 )
7538 PARAMETER ( ONEONE = 1.D+00 )
7539 PARAMETER ( TWOTWO = 2.D+00 )
7540 PARAMETER ( FIVFIV = 5.D+00 )
7541 PARAMETER ( HLFHLF = 0.5D+00 )
7543 PARAMETER ( NALLWP = 39 )
7544 PARAMETER ( IDMAXP = 210 )
7546 DIMENSION ICHRGE(39),AM(39)
7548 * particle properties (BAMJET index convention)
7550 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7551 & IICH(210),IIBAR(210),K1(210),K2(210)
7553 DIMENSION KPTOIP(210)
7554 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7555 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7556 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7557 & IQTCHR(-6:6),MQUARK(3,39)
7559 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7560 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7562 SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7563 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7564 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7565 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7567 * Conversion from part to paprop numbering
7568 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7569 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7570 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7572 * 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7573 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7574 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7575 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7577 * 1st reaction: gamma p total
7578 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7579 * 2nd reaction: gamma d total
7580 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7581 * 3rd reaction: pi+ p total
7582 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7583 * 4th reaction: pi- p total
7584 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7585 * 5th reaction: pi+/- d total
7586 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7587 * 6th reaction: K+ p total
7588 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7589 * 7th reaction: K+ n total
7590 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7591 * 8th reaction: K+ d total
7592 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7593 * 9th reaction: K- p total
7594 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7595 * 10th reaction: K- n total
7596 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7597 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7599 * 11th reaction: K- d total
7600 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7601 * 12th reaction: p p total
7602 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7603 * 13th reaction: p n total
7604 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7605 * 14th reaction: p d total
7606 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
7607 * 15th reaction: pbar p total
7608 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
7609 * 16th reaction: pbar n total
7610 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
7611 * 17th reaction: pbar d total
7612 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
7613 * 18th reaction: Lamda p total
7614 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
7615 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7617 * 19th reaction: pi+ p elastic
7618 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
7619 * 20th reaction: pi- p elastic
7620 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
7621 * 21st reaction: K+ p elastic
7622 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
7623 * 22nd reaction: K- p elastic
7624 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
7625 * 23rd reaction: p p elastic
7626 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
7627 * 24th reaction: p d elastic
7628 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
7629 * 25th reaction: pbar p elastic
7630 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
7631 * 26th reaction: pbar p elastic bis
7632 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
7633 * 27th reaction: pbar n elastic
7634 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
7635 * 28th reaction: Lamda p elastic
7636 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
7637 * 29th reaction: K- p ela bis
7638 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
7639 * 30th reaction: pi- p cx
7640 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
7641 * 31st reaction: K- p cx
7642 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
7643 * 32nd reaction: K+ n cx
7644 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
7645 * 33rd reaction: pbar p cx
7646 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
7648 * +-------------------------------------------------------------------*
7649 ICHRGE(KTARG)=IICH(KTARG)
7650 AM (KTARG)=AAM (KTARG)
7651 * | Check for pi0 (d-dbar)
7652 IF ( KP .NE. 26 ) THEN
7658 * +-------------------------------------------------------------------*
7665 * +-------------------------------------------------------------------*
7666 * +-------------------------------------------------------------------*
7667 * | No such interactions for baryon-baryon
7668 IF ( IIBAR (KP) .GT. 0 ) THEN
7672 * +-------------------------------------------------------------------*
7673 * | No "annihilation" diagram possible for K+ p/n
7674 ELSE IF ( IP .EQ. 15 ) THEN
7678 * +-------------------------------------------------------------------*
7679 * | No "annihilation" diagram possible for K0 p/n
7680 ELSE IF ( IP .EQ. 24 ) THEN
7684 * +-------------------------------------------------------------------*
7685 * | No "annihilation" diagram possible for Omebar p/n
7686 ELSE IF ( IP .GE. 38 ) THEN
7691 * +-------------------------------------------------------------------*
7692 * +-------------------------------------------------------------------*
7693 * | If the momentum is larger than 50 GeV/c, compute the single
7694 * | chain probability at 50 GeV/c and extrapolate to the present
7695 * | momentum according to 1/sqrt(s)
7696 * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7697 * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7698 * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7699 * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7701 * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7702 IF ( PLAB .GT. 50.D+00 ) THEN
7705 AMTSQ = AM (KTARG)**2
7706 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7707 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7708 EPROJ = SQRT ( PLA**2 + AMPSQ )
7709 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7710 UMORAT = SQRT ( UMOSQ / UMO50 )
7712 * +-------------------------------------------------------------------*
7714 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7717 AMTSQ = AM (KTARG)**2
7718 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7719 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7720 EPROJ = SQRT ( PLA**2 + AMPSQ )
7721 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7722 UMORAT = SQRT ( UMOSQ / UMO50 )
7724 * +-------------------------------------------------------------------*
7731 * +-------------------------------------------------------------------*
7733 * +-------------------------------------------------------------------*
7735 IF ( IHLP (IP) .EQ. 2 ) THEN
7741 * | Compute the pi+ p total cross section:
7742 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7744 ACOF = SGTCOE (1,19)
7745 BCOF = SGTCOE (2,19)
7746 ENNE = SGTCOE (3,19)
7747 CCOF = SGTCOE (4,19)
7748 DCOF = SGTCOE (5,19)
7749 * | Compute the pi+ p elastic cross section:
7750 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7752 * | Compute the pi+ p inelastic cross section:
7753 SPPPIN = SPPPTT - SPPPEL
7759 * | Compute the pi- p total cross section:
7760 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7762 ACOF = SGTCOE (1,20)
7763 BCOF = SGTCOE (2,20)
7764 ENNE = SGTCOE (3,20)
7765 CCOF = SGTCOE (4,20)
7766 DCOF = SGTCOE (5,20)
7767 * | Compute the pi- p elastic cross section:
7768 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7770 * | Compute the pi- p inelastic cross section:
7771 SPMPIN = SPMPTT - SPMPEL
7772 SIGDIA = SPMPIN - SPPPIN
7773 * | +----------------------------------------------------------------*
7774 * | | Charged pions: besides isospin consideration it is supposed
7775 * | | that (pi+ n)el is almost equal to (pi- p)el
7776 * | | and (pi+ p)el " " " " (pi- n)el
7777 * | | and all are almost equal among each others
7778 * | | (reasonable above 5 GeV/c)
7779 IF ( ICHRGE (IP) .NE. 0 ) THEN
7781 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7782 ACOF = SGTCOE (1,JREAC)
7783 BCOF = SGTCOE (2,JREAC)
7784 ENNE = SGTCOE (3,JREAC)
7785 CCOF = SGTCOE (4,JREAC)
7786 DCOF = SGTCOE (5,JREAC)
7787 * | | Compute the total cross section:
7788 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7790 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7791 ACOF = SGTCOE (1,JREAC)
7792 BCOF = SGTCOE (2,JREAC)
7793 ENNE = SGTCOE (3,JREAC)
7794 CCOF = SGTCOE (4,JREAC)
7795 DCOF = SGTCOE (5,JREAC)
7796 * | | Compute the elastic cross section:
7797 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7799 * | | Compute the inelastic cross section:
7800 SHNCIN = SHNCTT - SHNCEL
7801 * | | Number of diagrams:
7802 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7803 * | | Now compute the chain end (anti)quark-(anti)diquark
7804 IQFSC1 = 1 + IP - 13
7807 IQBSC2 = 1 + IP - 13
7809 * | +----------------------------------------------------------------*
7810 * | | pi0: besides isospin consideration it is supposed that the
7811 * | | elastic cross section is not very different from
7812 * | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
7815 K2HLP = ( KP - 23 ) / 3
7816 * | | Number of diagrams:
7817 * | | For u ubar (k2hlp=0):
7818 * NDIAGR = 2 - KHELP
7819 * | | For d dbar (k2hlp=1):
7820 * NDIAGR = 2 + KHELP - K2HLP
7821 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7822 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7823 * | | Now compute the chain end (anti)quark-(anti)diquark
7830 * | +----------------------------------------------------------------*
7832 * +-------------------------------------------------------------------*
7834 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7840 * | Compute the K+ p total cross section:
7841 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7843 ACOF = SGTCOE (1,21)
7844 BCOF = SGTCOE (2,21)
7845 ENNE = SGTCOE (3,21)
7846 CCOF = SGTCOE (4,21)
7847 DCOF = SGTCOE (5,21)
7848 * | Compute the K+ p elastic cross section:
7849 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7851 * | Compute the K+ p inelastic cross section:
7852 SKPPIN = SKPPTT - SKPPEL
7858 * | Compute the K- p total cross section:
7859 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7861 ACOF = SGTCOE (1,22)
7862 BCOF = SGTCOE (2,22)
7863 ENNE = SGTCOE (3,22)
7864 CCOF = SGTCOE (4,22)
7865 DCOF = SGTCOE (5,22)
7866 * | Compute the K- p elastic cross section:
7867 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7869 * | Compute the K- p inelastic cross section:
7870 SKMPIN = SKMPTT - SKMPEL
7871 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7872 * | +----------------------------------------------------------------*
7873 * | | Charged Kaons: actually only K-
7874 IF ( ICHRGE (IP) .NE. 0 ) THEN
7876 * | | +-------------------------------------------------------------*
7877 * | | | Proton target:
7878 IF ( KHELP .EQ. 0 ) THEN
7880 * | | | Number of diagrams:
7883 * | | +-------------------------------------------------------------*
7884 * | | | Neutron target: besides isospin consideration it is supposed
7885 * | | | that (K- n)el is almost equal to (K- p)el
7886 * | | | (reasonable above 5 GeV/c)
7888 ACOF = SGTCOE (1,10)
7889 BCOF = SGTCOE (2,10)
7890 ENNE = SGTCOE (3,10)
7891 CCOF = SGTCOE (4,10)
7892 DCOF = SGTCOE (5,10)
7893 * | | | Compute the total cross section:
7894 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7896 * | | | Compute the elastic cross section:
7898 * | | | Compute the inelastic cross section:
7899 SHNCIN = SHNCTT - SHNCEL
7900 * | | | Number of diagrams:
7904 * | | +-------------------------------------------------------------*
7905 * | | Now compute the chain end (anti)quark-(anti)diquark
7911 * | +----------------------------------------------------------------*
7912 * | | K0's: (actually only K0bar)
7915 * | | +-------------------------------------------------------------*
7916 * | | | Proton target: (K0bar p)in supposed to be given by
7917 * | | | (K- p)in - Sig_diagr
7918 IF ( KHELP .EQ. 0 ) THEN
7919 SHNCIN = SKMPIN - SIGDIA
7920 * | | | Number of diagrams:
7923 * | | +-------------------------------------------------------------*
7924 * | | | Neutron target: (K0bar n)in supposed to be given by
7925 * | | | (K- n)in + Sig_diagr
7926 * | | | besides isospin consideration it is supposed
7927 * | | | that (K- n)el is almost equal to (K- p)el
7928 * | | | (reasonable above 5 GeV/c)
7930 ACOF = SGTCOE (1,10)
7931 BCOF = SGTCOE (2,10)
7932 ENNE = SGTCOE (3,10)
7933 CCOF = SGTCOE (4,10)
7934 DCOF = SGTCOE (5,10)
7935 * | | | Compute the total cross section:
7936 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7938 * | | | Compute the elastic cross section:
7940 * | | | Compute the inelastic cross section:
7941 SHNCIN = SHNCTT - SHNCEL + SIGDIA
7942 * | | | Number of diagrams:
7946 * | | +-------------------------------------------------------------*
7947 * | | Now compute the chain end (anti)quark-(anti)diquark
7954 * | +----------------------------------------------------------------*
7956 * +-------------------------------------------------------------------*
7958 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7959 * | For momenta between 3 and 5 GeV/c the use of tabulated data
7960 * | should be implemented!
7961 ACOF = SGTCOE (1,15)
7962 BCOF = SGTCOE (2,15)
7963 ENNE = SGTCOE (3,15)
7964 CCOF = SGTCOE (4,15)
7965 DCOF = SGTCOE (5,15)
7966 * | Compute the pbar p total cross section:
7967 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7969 IF ( PLA .LT. FIVFIV ) THEN
7974 ACOF = SGTCOE (1,JREAC)
7975 BCOF = SGTCOE (2,JREAC)
7976 ENNE = SGTCOE (3,JREAC)
7977 CCOF = SGTCOE (4,JREAC)
7978 DCOF = SGTCOE (5,JREAC)
7979 * | Compute the pbar p elastic cross section:
7980 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7982 * | Compute the pbar p inelastic cross section:
7983 SAPPIN = SAPPTT - SAPPEL
7984 ACOF = SGTCOE (1,12)
7985 BCOF = SGTCOE (2,12)
7986 ENNE = SGTCOE (3,12)
7987 CCOF = SGTCOE (4,12)
7988 DCOF = SGTCOE (5,12)
7989 * | Compute the p p total cross section:
7990 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7992 ACOF = SGTCOE (1,23)
7993 BCOF = SGTCOE (2,23)
7994 ENNE = SGTCOE (3,23)
7995 CCOF = SGTCOE (4,23)
7996 DCOF = SGTCOE (5,23)
7997 * | Compute the p p elastic cross section:
7998 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8000 * | Compute the K- p inelastic cross section:
8001 SPPINE = SPPTOT - SPPELA
8002 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8004 * | +----------------------------------------------------------------*
8006 IF ( ICHRGE (IP) .NE. 0 ) THEN
8008 * | | +-------------------------------------------------------------*
8009 * | | | Proton target:
8010 IF ( KHELP .EQ. 0 ) THEN
8011 * | | | Number of diagrams:
8015 * | | +-------------------------------------------------------------*
8016 * | | | Neutron target: it is supposed that (ap n)el is almost equal
8017 * | | | to (ap p)el (reasonable above 5 GeV/c)
8019 ACOF = SGTCOE (1,16)
8020 BCOF = SGTCOE (2,16)
8021 ENNE = SGTCOE (3,16)
8022 CCOF = SGTCOE (4,16)
8023 DCOF = SGTCOE (5,16)
8024 * | | | Compute the total cross section:
8025 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8027 * | | | Compute the elastic cross section:
8029 * | | | Compute the inelastic cross section:
8030 SHNCIN = SHNCTT - SHNCEL
8034 * | | +-------------------------------------------------------------*
8035 * | | Now compute the chain end (anti)quark-(anti)diquark
8036 * | | there are different possibilities, make a random choiche:
8038 RNCHEN = DT_RNDM(PUUBAR)
8039 IF ( RNCHEN .LT. PUUBAR ) THEN
8044 IQBSC1 = -IQFSC1 + KHELP
8047 * | +----------------------------------------------------------------*
8051 * | | +-------------------------------------------------------------*
8052 * | | | Proton target: (nbar p)in supposed to be given by
8053 * | | | (pbar p)in - Sig_diagr
8054 IF ( KHELP .EQ. 0 ) THEN
8055 SHNCIN = SAPPIN - SIGDIA
8058 * | | +-------------------------------------------------------------*
8059 * | | | Neutron target: (nbar n)el is supposed to be equal to
8060 * | | | (pbar p)el (reasonable above 5 GeV/c)
8062 * | | | Compute the total cross section:
8064 * | | | Compute the elastic cross section:
8066 * | | | Compute the inelastic cross section:
8067 SHNCIN = SHNCTT - SHNCEL
8071 * | | +-------------------------------------------------------------*
8072 * | | Now compute the chain end (anti)quark-(anti)diquark
8073 * | | there are different possibilities, make a random choiche:
8075 RNCHEN = DT_RNDM(RNCHEN)
8076 IF ( RNCHEN .LT. PDDBAR ) THEN
8081 IQBSC1 = -IQFSC1 + KHELP - 1
8085 * | +----------------------------------------------------------------*
8087 * +-------------------------------------------------------------------*
8088 * | Others: not yet implemented
8097 * +-------------------------------------------------------------------*
8098 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8099 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8101 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8105 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8107 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8108 & + IQSCHR (MQUARK(3,IP))
8109 * +-------------------------------------------------------------------*
8110 * | Consistency check:
8111 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8112 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8113 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8114 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8115 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8116 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8117 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8120 * +-------------------------------------------------------------------*
8121 * +-------------------------------------------------------------------*
8122 * | Consistency check:
8123 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8124 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8126 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8127 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8129 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8130 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8133 * +-------------------------------------------------------------------*
8134 * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8135 IF ( UMORAT .GT. ONEPLS )
8136 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8137 & - ONEONE ) * UMORAT + ONEONE )
8140 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8146 *=== End of function Phnsch ===========================================*
8150 *===respt==============================================================*
8155 ************************************************************************
8156 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8157 * This version dated 18.01.95 is written by S. Roesler *
8158 ************************************************************************
8160 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8163 PARAMETER ( LINP = 5 ,
8167 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8171 PARAMETER (NMXHKK=200000)
8173 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8174 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8175 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8176 * extended event history
8177 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8178 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8181 * get index of first chain
8182 DO 1 I=NPOINT(3),NHKK
8183 IF (IDHKK(I).EQ.88888) THEN
8190 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8191 C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8192 * skip VV-,SS- systems
8193 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8194 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8195 * check if both "chains" are resonances
8196 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8197 CALL DT_SAPTRE(NC,NC+3)
8211 *===evtres=============================================================*
8213 CDECK ID>, DT_EVTRES
8214 SUBROUTINE DT_EVTRES(IREJ)
8216 ************************************************************************
8217 * This version dated 14.12.94 is written by S. Roesler *
8218 ************************************************************************
8220 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8223 PARAMETER ( LINP = 5 ,
8227 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8231 PARAMETER (NMXHKK=200000)
8233 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8234 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8235 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8236 * extended event history
8237 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8238 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8240 * flags for input different options
8241 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8242 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8243 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8244 * particle properties (BAMJET index convention)
8246 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8247 & IICH(210),IIBAR(210),K1(210),K2(210)
8249 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8253 DO 1 I=NPOINT(3),NHKK
8254 IF (ABS(IDRES(I)).GE.100) THEN
8256 DO 2 J=NPOINT(3),NHKK
8257 IF (IDHKK(J).EQ.88888) THEN
8258 IF (PHKK(5,J).GT.AMMX) THEN
8264 IF (IDRES(IMMX).NE.0) THEN
8265 IF (IOULEV(3).GT.0) THEN
8266 WRITE(LOUT,'(1X,A)')
8267 & 'EVTRES: no chain for correc. found'
8276 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8280 IMO21 = JMOHKK(1,IMMX)
8281 IMO22 = JMOHKK(2,IMMX)
8282 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8283 IMO21 = JMOHKK(2,IMMX)
8284 IMO22 = JMOHKK(1,IMMX)
8287 AMCH1N = AAM(IDXRES(I))
8289 IFPR1 = IDHKK(IMO11)
8290 IFPR2 = IDHKK(IMO21)
8291 IFTA1 = IDHKK(IMO12)
8292 IFTA2 = IDHKK(IMO22)
8294 PP1(J) = PHKK(J,IMO11)
8295 PP2(J) = PHKK(J,IMO21)
8296 PT1(J) = PHKK(J,IMO12)
8297 PT2(J) = PHKK(J,IMO22)
8299 * store initial configuration for energy-momentum cons. check
8300 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8301 * correct kinematics of second chain
8302 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8303 & AMCH1,AMCH1N,AMCH2,IREJ1)
8304 IF (IREJ1.NE.0) GOTO 9999
8305 * check now this chain for resonance mass
8306 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8308 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8309 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8311 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8313 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8314 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8315 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8316 & AMCH2,AMCH2N,IDCH2,IREJ1)
8317 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8319 & WRITE(LOUT,*) ' correction for resonance not poss.'
8325 * store final configuration for energy-momentum cons. check
8327 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8328 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8329 IF (IREJ1.NE.0) GOTO 9999
8332 PHKK(J,IMO11) = PP1(J)
8333 PHKK(J,IMO21) = PP2(J)
8334 PHKK(J,IMO12) = PT1(J)
8335 PHKK(J,IMO22) = PT2(J)
8337 * correct entries of chains
8339 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8340 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8342 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8343 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8345 * ?? the following should now be obsolete
8347 C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8348 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8350 WRITE(LOUT,'(1X,A,4G10.3)')
8351 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8355 PHKK(5,I) = SQRT(AM1)
8356 PHKK(5,IMMX) = SQRT(AM2)
8357 IDRES(I) = IDRES(I)/100
8358 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8359 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8360 WRITE(LOUT,'(1X,A,4G10.3)')
8361 & 'EVTRES: inconsistent chain-masses',
8362 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8375 *===getspt=============================================================*
8377 CDECK ID>, DT_GETSPT
8378 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8379 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8380 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8382 ************************************************************************
8383 * This version dated 12.12.94 is written by S. Roesler *
8384 ************************************************************************
8386 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8389 PARAMETER ( LINP = 5 ,
8393 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8395 * various options for treatment of partons (DTUNUC 1.x)
8396 * (chain recombination, Cronin,..)
8397 LOGICAL LCO2CR,LINTPT
8398 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8400 * flags for input different options
8401 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8402 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8403 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8404 * flags for diffractive interactions (DTUNUC 1.x)
8405 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8407 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8408 & PT2(4),PT2I(4),P1(4),P2(4),
8409 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8410 & PTOTI(4),PTOTF(4),DIFF(4)
8416 C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8417 C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8423 IF (IDIFF.NE.0) THEN
8429 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8435 * get initial chain masses
8436 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8437 & +(PP1(3)+PT1(3))**2)
8439 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8440 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8441 & +(PP2(3)+PT2(3))**2)
8443 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8444 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8446 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8456 C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8460 C IF (AM1.LT.0.6) THEN
8462 C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8465 C IF (AM2.LT.0.6) THEN
8467 C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8472 * check chain masses for very low mass chains
8473 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8474 C & AM1,DUM,-IDCH1,IREJ1)
8475 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8476 C & AM2,DUM,-IDCH2,IREJ2)
8477 C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8486 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8487 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8488 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8489 C IF (MOD(IC,19).EQ.0) JMSHL = 0
8490 IF (MOD(IC,20).EQ.0) GOTO 7
8491 C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8496 * get transverse momentum
8498 ES = -2.0D0/(B33P**2)
8499 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8500 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8502 ES = -2.0D0/(B33T**2)
8503 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8504 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8510 CALL DT_DSFECF(SFE1,CFE1)
8511 CALL DT_DSFECF(SFE2,CFE2)
8513 PP1(1) = PP1I(1)+HPSP*CFE1
8514 PP1(2) = PP1I(2)+HPSP*SFE1
8515 PP2(1) = PP2I(1)-HPSP*CFE1
8516 PP2(2) = PP2I(2)-HPSP*SFE1
8517 PT1(1) = PT1I(1)+HPST*CFE2
8518 PT1(2) = PT1I(2)+HPST*SFE2
8519 PT2(1) = PT2I(1)-HPST*CFE2
8520 PT2(2) = PT2I(2)-HPST*SFE2
8522 PP1(1) = PP1I(1)+HPSP*CFE1
8523 PP1(2) = PP1I(2)+HPSP*SFE1
8524 PT1(1) = PT1I(1)-HPSP*CFE1
8525 PT1(2) = PT1I(2)-HPSP*SFE1
8526 PP2(1) = PP2I(1)+HPST*CFE2
8527 PP2(2) = PP2I(2)+HPST*SFE2
8528 PT2(1) = PT2I(1)-HPST*CFE2
8529 PT2(2) = PT2I(2)-HPST*SFE2
8532 * put partons on mass shell
8535 IF (JMSHL.EQ.1) THEN
8537 XMP1 = PYMASS(IFPR1)
8538 XMT1 = PYMASS(IFTA1)
8541 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8542 IF (IREJ1.NE.0) GOTO 2
8544 PTOTF(I) = P1(I)+P2(I)
8550 IF (JMSHL.EQ.1) THEN
8552 XMP2 = PYMASS(IFPR2)
8553 XMT2 = PYMASS(IFTA2)
8556 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8557 IF (IREJ1.NE.0) GOTO 2
8559 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8566 DIFF(I) = PTOTI(I)-PTOTF(I)
8568 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8569 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8570 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8573 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8574 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8575 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8576 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8577 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8578 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8579 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8580 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8581 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8582 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8584 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8585 & 'GETSPT: inconsistent masses',
8586 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8587 * sr 22.11.00: commented. It should only have inconsistent masses for
8588 * ultrahigh energies due to rounding problems
8593 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8594 & +(PP1(3)+PT1(3))**2)
8596 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
8597 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8598 & +(PP2(3)+PT2(3))**2)
8600 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
8601 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8603 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8610 * check chain masses for very low mass chains
8611 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8612 & AM1N,DUM,-IDCH1,IREJ1)
8613 IF (IREJ1.NE.0) GOTO 2
8614 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8615 & AM2N,DUM,-IDCH2,IREJ2)
8616 IF (IREJ2.NE.0) GOTO 2
8619 IF (AM1N.GT.ZERO) THEN
8637 *===saptre=============================================================*
8639 CDECK ID>, DT_SAPTRE
8640 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8642 ************************************************************************
8643 * p-t sampling for two-resonance systems. ("BAMJET-like" method) *
8644 * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
8645 * Adopted from the original SAPTRE written by J. Ranft. *
8646 * This version dated 18.01.95 is written by S. Roesler *
8647 ************************************************************************
8649 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8652 PARAMETER ( LINP = 5 ,
8656 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8660 PARAMETER (NMXHKK=200000)
8662 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8663 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8664 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8665 * extended event history
8666 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8667 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8669 * flags for input different options
8670 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8671 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8672 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8674 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8678 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8679 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8680 ESMAX = MIN(ESMAX1,ESMAX2)
8681 IF (ESMAX.LE.0.05D0) RETURN
8685 PA1(K) = PHKK(K,IDX1)
8686 PA2(K) = PHKK(K,IDX2)
8690 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8691 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8695 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8696 BEXP = HMA*(1.0D0-EXEB)/B3
8697 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8698 WA = AXEXP/(BEXP+AXEXP)
8701 * ES is the transverse kinetic energy
8705 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8708 ES = ABS(-LOG(X+TINY7)/B3)
8710 IF (ES.GT.ESMAX) GOTO 10
8712 * transverse momentum
8713 HPS = SQRT((ES-HMA)*(ES+HMA))
8715 CALL DT_DSFECF(SFE,CFE)
8718 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8719 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8720 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8722 C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8723 C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8729 * put resonances on mass-shell again
8732 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8733 IF (IREJ1.NE.0) RETURN
8736 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8737 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8738 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8739 IF (IREJ1.NE.0) RETURN
8743 PHKK(K,IDX1) = P1(K)
8744 PHKK(K,IDX2) = P2(K)
8750 *===cronin=============================================================*
8752 CDECK ID>, DT_CRONIN
8753 SUBROUTINE DT_CRONIN(INCL)
8755 ************************************************************************
8756 * Cronin-Effect. Multiple scattering of partons at chain ends. *
8757 * INCL = 1 multiple sc. in projectile *
8758 * = 2 multiple sc. in target *
8759 * This version dated 05.01.96 is written by S. Roesler. *
8760 ************************************************************************
8762 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8765 PARAMETER ( LINP = 5 ,
8769 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8773 PARAMETER (NMXHKK=200000)
8775 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8776 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8777 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8778 * extended event history
8779 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8780 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8783 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8784 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8785 & IREXCI(3),IRDIFF(2),IRINC
8786 * Glauber formalism: collision properties
8787 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8788 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8790 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8796 DO 2 I=NPOINT(2),NHKK
8797 IF (ISTHKK(I).LT.0) THEN
8798 * get z-position of the chain
8799 R(1) = VHKK(1,I)*1.0D12
8800 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8801 R(2) = VHKK(2,I)*1.0D12
8803 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8804 & IDXNU = JMOHKK(1,I-1)
8805 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8806 & IDXNU = JMOHKK(1,I+1)
8807 R(3) = VHKK(3,IDXNU)*1.0D12
8808 * position of target parton the chain is connected to
8812 * multiple scattering of parton with DTEVT1-index I
8813 CALL DT_CROMSC(PIN,R,POUT,INCL)
8815 C IF (NEVHKK.EQ.5) THEN
8816 C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8817 C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8818 C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8819 C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8820 C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8821 C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
8822 C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
8825 * increase accumulator by energy-momentum difference
8827 DEV(K) = DEV(K)+POUT(K)-PIN(K)
8830 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8831 & PHKK(2,I)**2-PHKK(3,I)**2))
8835 * dump accumulator to momenta of valence partons
8838 DO 5 I=NPOINT(2),NHKK
8839 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8841 ETOT = ETOT+PHKK(4,I)
8844 C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8845 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
8847 DO 6 I=NPOINT(2),NHKK
8848 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8851 C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8852 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8854 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8855 & PHKK(2,I)**2-PHKK(3,I)**2))
8862 *===cromsc=============================================================*
8864 CDECK ID>, DT_CROMSC
8865 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8867 ************************************************************************
8868 * Cronin-Effect. Multiple scattering of one parton passing through *
8870 * PIN(4) input 4-momentum of parton *
8871 * POUT(4) 4-momentum of parton after mult. scatt. *
8872 * R(3) spatial position of parton in target nucleus *
8873 * INCL = 1 multiple sc. in projectile *
8874 * = 2 multiple sc. in target *
8875 * This is a revised version of the original version written by J. Ranft*
8876 * This version dated 17.01.95 is written by S. Roesler. *
8877 ************************************************************************
8879 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8882 PARAMETER ( LINP = 5 ,
8886 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8891 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8892 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8893 & IREXCI(3),IRDIFF(2),IRINC
8894 * Glauber formalism: collision properties
8895 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8896 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8897 * various options for treatment of partons (DTUNUC 1.x)
8898 * (chain recombination, Cronin,..)
8899 LOGICAL LCO2CR,LINTPT
8900 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8903 DIMENSION PIN(4),POUT(4),R(3)
8905 DATA LSTART /.TRUE./
8907 IRCRON(1) = IRCRON(1)+1
8910 WRITE(LOUT,1000) CRONCO
8911 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
8912 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8918 IF (INCL.EQ.2) RNCL = RTARG
8920 * Lorentz-transformation into Lab.
8922 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8924 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8925 IF (PTOT.LE.8.0D0) GOTO 9997
8927 * direction cosines of parton before mult. scattering
8932 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8933 IF (RTESQ.GE.-TINY3) GOTO 9999
8935 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8936 * in the direction of particle motion
8938 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8940 IF (TMP.LT.ZERO) GOTO 9998
8943 * multiple scattering angle
8944 THETO = CRONCO*SQRT(DIST)/PTOT
8945 IF (THETO.GT.0.1D0) THETO=0.1D0
8948 * Gaussian sampling of spatial angle
8949 CALL DT_RANNOR(R1,R2)
8950 THETA = ABS(R1*THETO)
8951 IF (THETA.GT.0.3D0) GOTO 9997
8952 CALL DT_DSFECF(SFE,CFE)
8956 * new direction cosines
8957 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8958 & COSXN,COSYN,COSZN)
8960 POUT(1) = COSXN*PTOT
8961 POUT(2) = COSYN*PTOT
8963 * Lorentz-transformation into nucl.-nucl. cms
8965 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8967 C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8968 C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8969 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8972 IF (MOD(NCBACK,200).EQ.0) THEN
8973 WRITE(LOUT,1001) THETO,PIN,POUT
8974 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8975 & E12.4,/,1X,' PIN :',4E12.4,/,
8976 & 1X,' POUT:',4E12.4)
8984 9997 IRCRON(2) = IRCRON(2)+1
8986 9998 IRCRON(3) = IRCRON(3)+1
8995 *===com2sr=============================================================*
8997 CDECK ID>, DT_COM2CR
8998 SUBROUTINE DT_COM2CR
9000 ************************************************************************
9001 * COMbine q-aq chains to Color Ropes (qq-aqaq). *
9002 * CUTOF parameter determining minimum number of not *
9003 * combined q-aq chains *
9004 * This subroutine replaces KKEVCC etc. *
9005 * This version dated 11.01.95 is written by S. Roesler. *
9006 ************************************************************************
9008 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9011 PARAMETER ( LINP = 5 ,
9017 PARAMETER (NMXHKK=200000)
9019 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9020 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9021 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9022 * extended event history
9023 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9024 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9027 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9028 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9030 * various options for treatment of partons (DTUNUC 1.x)
9031 * (chain recombination, Cronin,..)
9032 LOGICAL LCO2CR,LINTPT
9033 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9036 DIMENSION IDXQA(248),IDXAQ(248)
9038 ICCHAI(1,9) = ICCHAI(1,9)+1
9041 * scan DTEVT1 for q-aq, aq-q chains
9042 DO 10 I=NPOINT(3),NHKK
9043 * skip "chains" which are resonances
9044 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9047 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9048 * q-aq, aq-q chain found, keep index
9049 IF (IDHKK(MO1).GT.0) THEN
9060 * minimum number of q-aq chains requested for the same projectile/
9062 NCHMIN = IDT_NPOISS(CUTOF)
9064 * combine q-aq chains of the same projectile
9065 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9066 * combine q-aq chains of the same target
9067 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9068 * combine aq-q chains of the same projectile
9069 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9070 * combine aq-q chains of the same target
9071 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9076 *===scn4cr=============================================================*
9078 CDECK ID>, DT_SCN4CR
9079 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9081 ************************************************************************
9082 * SCan q-aq chains for Color Ropes. *
9083 * This version dated 11.01.95 is written by S. Roesler. *
9084 ************************************************************************
9086 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9089 PARAMETER ( LINP = 5 ,
9095 PARAMETER (NMXHKK=200000)
9097 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9098 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9099 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9100 * extended event history
9101 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9102 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9105 DIMENSION IDXCH(248),IDXJN(248)
9108 IF (IDXCH(I).GT.0) THEN
9110 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9114 IF (IDXCH(J).GT.0) THEN
9115 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9116 IF (IDXMO.EQ.IDXMO1) THEN
9123 IF (NJOIN.GE.NCHMIN+2) THEN
9124 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9126 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9127 IF (IREJ1.NE.0) GOTO 3
9129 IDXCH(IDXJN(J+1)) = 0
9138 *===join===============================================================*
9141 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9143 ************************************************************************
9144 * This subroutine joins two q-aq chains to one qq-aqaq chain. *
9145 * IDX1, IDX2 DTEVT1 indices of chains to be joined *
9146 * This version dated 11.01.95 is written by S. Roesler. *
9147 ************************************************************************
9149 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9152 PARAMETER ( LINP = 5 ,
9158 PARAMETER (NMXHKK=200000)
9160 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9161 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9162 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9163 * extended event history
9164 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9165 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9167 * flags for input different options
9168 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9169 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9170 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9172 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9173 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9176 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9184 MO(I,J) = JMOHKK(J,IDX(I))
9185 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9190 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9191 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9192 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9193 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9194 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9196 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9197 & 2I5,' chain ',I4,':',2I5)
9202 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9203 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9205 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9206 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9207 IST1 = ISTHKK(MO(1,1))
9208 IST2 = ISTHKK(MO(1,2))
9210 * put partons again on mass shell
9213 IF (IMSHL.EQ.1) THEN
9219 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9220 IF (IREJ1.NE.0) GOTO 9999
9226 * store new partons in DTEVT1
9227 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9229 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9232 PCH(K) = PP(K)+PT(K)
9235 * check new chain for lower mass limit
9236 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9237 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9238 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9239 & AMCH,AMCHN,3,IREJ1)
9240 IF (IREJ1.NE.0) THEN
9246 ICCHAI(2,9) = ICCHAI(2,9)+1
9247 * store new chain in DTEVT1
9249 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9250 IDHKK(IDX(1)) = 22222
9251 IDHKK(IDX(2)) = 22222
9252 * special treatment for space-time coordinates
9254 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9255 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9264 *===xsglau=============================================================*
9266 CDECK ID>, DT_XSGLAU
9267 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9269 ************************************************************************
9270 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9271 * Glauber's approach. *
9272 * NA / NB mass numbers of proj./target nuclei *
9273 * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9274 * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9275 * IE,IQ indices of energy and virtuality (the latter for gamma *
9276 * projectiles only) *
9277 * NIDX index of projectile/target nucleus *
9278 * This version dated 17.3.98 is written by S. Roesler *
9279 ************************************************************************
9281 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9284 PARAMETER ( LINP = 5 ,
9288 COMPLEX*16 CZERO,CONE,CTWO
9290 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9291 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9292 PARAMETER (TWOPI = 6.283185307179586454D+00,
9294 & GEV2MB = 0.38938D0,
9295 & GEV2FM = 0.1972D0,
9296 & ALPHEM = ONE/137.0D0,
9300 * approx. nucleon radius
9303 * particle properties (BAMJET index convention)
9305 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9306 & IICH(210),IIBAR(210),K1(210),K2(210)
9308 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9310 PARAMETER ( MAXNCL = 260,
9313 & MAXSQU = 20*MAXVQU,
9314 & MAXINT = MAXVQU+MAXSQU)
9315 * Glauber formalism: parameters
9316 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9317 & BMAX(NCOMPX),BSTEP(NCOMPX),
9318 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9320 * Glauber formalism: cross sections
9321 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9322 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9323 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9324 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9325 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9326 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9327 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9328 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9329 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9330 & BSLOPE,NEBINI,NQBINI
9331 * Glauber formalism: flags and parameters for statistics
9334 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9335 * nucleon-nucleon event-generator
9338 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9339 * VDM parameter for photon-nucleus interactions
9340 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9341 * parameters for hA-diffraction
9342 COMMON /DTDIHA/ DIBETA,DIALPH
9344 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9345 & OMPP11,OMPP12,OMPP21,OMPP22,
9346 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9349 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9350 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9353 PARAMETER (NPOINT=16)
9354 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9356 LOGICAL LFIRST,LOPEN
9357 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9360 * for quasi-elastic neutrino scattering set projectile to proton
9361 * it should not have an effect since the whole Glauber-formalism is
9362 * not needed for these interactions..
9363 IF (MCGENE.EQ.4) THEN
9369 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9372 CFILE = CGLB//'.glb'
9373 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9374 ELSEIF (I.GT.1) THEN
9375 CFILE = CGLB(1:I-1)//'.glb'
9376 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9383 CZERO = DCMPLX(ZERO,ZERO)
9384 CONE = DCMPLX(ONE,ZERO)
9385 CTWO = DCMPLX(TWO,ZERO)
9389 * re-define kinematics
9393 * g(Q2=0)-A, h-A, A-A scattering
9394 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9397 * g(Q2>0)-A scattering
9398 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9400 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9401 Q2 = (S-AMP2)*X/(ONE-X)
9402 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9403 S = Q2*(ONE-X)/X+AMP2
9405 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9410 XNU = (S+Q2-AMP2)/(TWO*AMP)
9412 * parameters determining statistics in evaluating Glauber-xsection
9415 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9417 * set up interaction geometry (common /DTGLAM/)
9418 * projectile/target radii
9419 RPRNCL = DT_RNCLUS(NA)
9420 RTANCL = DT_RNCLUS(NB)
9421 IF (IJPROJ.EQ.7) THEN
9423 RBSH(NTARG) = RTANCL
9424 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9426 IF (NIDX.LE.-1) THEN
9428 RBSH(NTARG) = RTANCL
9429 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9431 RASH(NTARG) = RPRNCL
9433 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9436 * maximum impact-parameter
9437 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9439 * slope, rho ( Re(f(0))/Im(f(0)) )
9440 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9441 IF (MCGENE.EQ.2) THEN
9443 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9446 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9448 IF (ECMNN(IE).LE.3.0D0) THEN
9450 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9451 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9452 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9455 ELSEIF (IJPROJ.EQ.7) THEN
9458 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9462 * projectile-nucleon xsection (in fm)
9463 IF (IJPROJ.EQ.7) THEN
9464 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9466 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9467 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9468 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9470 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9471 SIGSH = SIGSH/10.0D0
9474 * parameters for projectile diffraction (hA scattering only)
9475 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9476 & .AND.(DIBETA.GE.ZERO)) THEN
9478 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9479 C DIBETA = SDIF1/STOT
9481 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9482 IF (DIBETA.LE.ZERO) THEN
9485 ALPGAM = DIALPH/DIGAMM
9489 FACDI = SQRT(FACDI1*FACDI2)
9490 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9502 BSITE( 0,IQ,NTARG,I) = ZERO
9503 BSITE(IE,IQ,NTARG,I) = ZERO
9522 FACN = ONE/DBLE(NSTATB)
9527 * initialize Gauss-integration for photon-proj.
9529 IF (IJPROJ.EQ.7) THEN
9530 IF (INTRGE(1).EQ.1) THEN
9531 AMLO2 = (3.0D0*AAM(13))**2
9532 ELSEIF (INTRGE(1).EQ.2) THEN
9537 IF (INTRGE(2).EQ.1) THEN
9539 ELSEIF (INTRGE(2).EQ.2) THEN
9544 AMHI20 = (ECMNN(IE)-AMP)**2
9545 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9546 XAMLO = LOG( AMLO2+Q2 )
9547 XAMHI = LOG( AMHI2+Q2 )
9549 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9552 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9556 * ratio direct/total photon-nucleon xsection
9557 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9560 * read pre-initialized profile-function from file
9561 IF (IOGLB.EQ.1) THEN
9562 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9563 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9564 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9565 & NA,NB,NSTATB,NSITEB
9566 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9567 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9568 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
9571 IF (LFIRST) WRITE(LOUT,1001) CFILE
9572 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9574 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9575 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9576 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9577 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9578 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9579 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9580 NLINES = INT(DBLE(NSITEB)/7.0D0)
9581 IF (NLINES.GT.0) THEN
9584 READ(LDAT,'(7E11.4)')
9585 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9589 IF (ISTART.LE.NSITEB) THEN
9590 READ(LDAT,'(7E11.4)')
9591 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9595 * variable projectile/target/energy runs:
9596 * read pre-initialized profile-functions from file
9597 ELSEIF (IOGLB.EQ.100) THEN
9598 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9602 * cross sections averaged over NSTATB nucleon configurations
9604 C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9614 IF (NIDX.LE.-1) THEN
9615 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9616 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9617 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9618 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9619 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9622 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9623 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9624 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9625 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9626 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9630 * integration over impact parameter B
9641 B = DBLE(IB)*BSTEP(NTARG)
9642 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
9644 * integration over M_V^2 for photon-proj.
9650 IF (IJPROJ.EQ.7) THEN
9662 IF (IJPROJ.EQ.7) THEN
9663 AMV2 = EXP(ABSZX(IM))-Q2
9665 IF (AMV2.LT.16.0D0) THEN
9667 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9672 * define M_V dependent properties of nucleon scattering amplitude
9673 * V_M-nucleon xsection
9674 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9675 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9676 * slope-parametrisation a la Kaidalov
9677 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9678 & +0.25D0*LOG(S/(AMV2+Q2)))
9680 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9681 * integration weight factor
9682 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9683 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9685 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9687 IF (IJPROJ.EQ.7) THEN
9688 RCA = GAM*SIGMV/TWOPI
9690 RCA = GAM*SIGSH/TWOPI
9693 CA = DCMPLX(RCA,FCA)
9702 * photon-projectile: check for supression by coherence length
9703 IF (IJPROJ.EQ.7) THEN
9704 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9708 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9714 X11 = B+COOT1(1,INB)-COOP1(1,INA)
9715 Y11 = COOT1(2,INB)-COOP1(2,INA)
9716 XY11 = GAM*(X11*X11+Y11*Y11)
9717 IF (XY11.LE.15.0D0) THEN
9718 C = CONE-CA*EXP(-XY11)
9719 AR = DBLE(PP11(INT1))
9720 AI = DIMAG(PP11(INT1))
9721 IF (ABS(AR).LT.TINY25) AR = ZERO
9722 IF (ABS(AI).LT.TINY25) AI = ZERO
9723 PP11(INT1) = DCMPLX(AR,AI)
9724 PP11(INT1) = PP11(INT1)*C
9727 SHI = SHI+LOG(AR*AR+AI*AI)
9729 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9730 X12 = B+COOT2(1,INB)-COOP1(1,INA)
9731 Y12 = COOT2(2,INB)-COOP1(2,INA)
9732 XY12 = GAM*(X12*X12+Y12*Y12)
9733 IF (XY12.LE.15.0D0) THEN
9734 C = CONE-CA*EXP(-XY12)
9735 AR = DBLE(PP12(INT2))
9736 AI = DIMAG(PP12(INT2))
9737 IF (ABS(AR).LT.TINY25) AR = ZERO
9738 IF (ABS(AI).LT.TINY25) AI = ZERO
9739 PP12(INT2) = DCMPLX(AR,AI)
9740 PP12(INT2) = PP12(INT2)*C
9742 X21 = B+COOT1(1,INB)-COOP2(1,INA)
9743 Y21 = COOT1(2,INB)-COOP2(2,INA)
9744 XY21 = GAM*(X21*X21+Y21*Y21)
9745 IF (XY21.LE.15.0D0) THEN
9746 C = CONE-CA*EXP(-XY21)
9747 AR = DBLE(PP21(INT1))
9748 AI = DIMAG(PP21(INT1))
9749 IF (ABS(AR).LT.TINY25) AR = ZERO
9750 IF (ABS(AI).LT.TINY25) AI = ZERO
9751 PP21(INT1) = DCMPLX(AR,AI)
9752 PP21(INT1) = PP21(INT1)*C
9754 X22 = B+COOT2(1,INB)-COOP2(1,INA)
9755 Y22 = COOT2(2,INB)-COOP2(2,INA)
9756 XY22 = GAM*(X22*X22+Y22*Y22)
9757 IF (XY22.LE.15.0D0) THEN
9758 C = CONE-CA*EXP(-XY22)
9759 AR = DBLE(PP22(INT2))
9760 AI = DIMAG(PP22(INT2))
9761 IF (ABS(AR).LT.TINY25) AR = ZERO
9762 IF (ABS(AI).LT.TINY25) AI = ZERO
9763 PP22(INT2) = DCMPLX(AR,AI)
9764 PP22(INT2) = PP22(INT2)*C
9775 IF (PP11(K).EQ.CZERO) THEN
9779 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9780 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9783 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9784 OMPP11 = OMPP11+AVDIPP
9785 C OMPP11 = OMPP11+(CONE-PP11(K))
9786 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9787 DIPP11 = DIPP11+AVDIPP
9788 IF (PP21(K).EQ.CZERO) THEN
9792 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9793 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9796 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9797 OMPP21 = OMPP21+AVDIPP
9798 C OMPP21 = OMPP21+(CONE-PP21(K))
9799 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9800 DIPP21 = DIPP21+AVDIPP
9807 IF (PP12(K).EQ.CZERO) THEN
9811 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9812 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9815 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9816 OMPP12 = OMPP12+AVDIPP
9817 C OMPP12 = OMPP12+(CONE-PP12(K))
9818 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9819 DIPP12 = DIPP12+AVDIPP
9820 IF (PP22(K).EQ.CZERO) THEN
9824 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9825 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9828 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9829 OMPP22 = OMPP22+AVDIPP
9830 C OMPP22 = OMPP22+(CONE-PP22(K))
9831 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9832 DIPP22 = DIPP22+AVDIPP
9835 SPROM = ONE-EXP(SHI)
9836 SPROB = SPROB+FACM*SPROM
9837 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9838 STOTM = DBLE(OMPP11+OMPP22)
9839 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9840 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9841 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9842 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9843 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9844 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9845 STOTB = STOTB+FACM*STOTM
9846 SELAB = SELAB+FACM*SELAM
9847 SDELB = SDELB+FACM*SDELM
9849 SQEPB = SQEPB+FACM*SQEPM
9850 SDQEB = SDQEB+FACM*SDQEM
9852 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9853 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9854 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9859 STOTN = STOTN+FACB*STOTB
9860 SELAN = SELAN+FACB*SELAB
9861 SQEPN = SQEPN+FACB*SQEPB
9862 SQETN = SQETN+FACB*SQETB
9863 SQE2N = SQE2N+FACB*SQE2B
9864 SPRON = SPRON+FACB*SPROB
9865 SDELN = SDELN+FACB*SDELB
9866 SDQEN = SDQEN+FACB*SDQEB
9868 IF (IJPROJ.EQ.7) THEN
9869 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9871 IF (DIBETA.GT.ZERO) THEN
9872 BPROD(IB+1)= BPROD(IB+1)
9873 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9875 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9881 STOT = STOT +FACN*STOTN
9882 STOT2 = STOT2+FACN*STOTN**2
9883 SELA = SELA +FACN*SELAN
9884 SELA2 = SELA2+FACN*SELAN**2
9885 SQEP = SQEP +FACN*SQEPN
9886 SQEP2 = SQEP2+FACN*SQEPN**2
9887 SQET = SQET +FACN*SQETN
9888 SQET2 = SQET2+FACN*SQETN**2
9889 SQE2 = SQE2 +FACN*SQE2N
9890 SQE22 = SQE22+FACN*SQE2N**2
9891 SPRO = SPRO +FACN*SPRON
9892 SPRO2 = SPRO2+FACN*SPRON**2
9893 SDEL = SDEL +FACN*SDELN
9894 SDEL2 = SDEL2+FACN*SDELN**2
9895 SDQE = SDQE +FACN*SDQEN
9896 SDQE2 = SDQE2+FACN*SDQEN**2
9900 * final cross sections
9902 XSTOT(IE,IQ,NTARG) = STOT
9904 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9906 XSELA(IE,IQ,NTARG) = SELA
9907 * 3) quasi-el.: A+B-->A+X (excluding 2)
9908 XSQEP(IE,IQ,NTARG) = SQEP
9909 * 4) quasi-el.: A+B-->X+B (excluding 2)
9910 XSQET(IE,IQ,NTARG) = SQET
9911 * 5) quasi-el.: A+B-->X (excluding 2-4)
9912 XSQE2(IE,IQ,NTARG) = SQE2
9913 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9914 IF (SDEL.GT.ZERO) THEN
9915 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9917 XSPRO(IE,IQ,NTARG) = SPRO
9919 * 7) projectile diffraction (el. scatt. off target)
9920 XSDEL(IE,IQ,NTARG) = SDEL
9921 * 8) projectile diffraction (quasi-el. scatt. off target)
9922 XSDQE(IE,IQ,NTARG) = SDQE
9924 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9925 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9926 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9927 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9928 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9929 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9930 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9931 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9933 IF (IJPROJ.EQ.7) THEN
9934 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9935 & -XSQEP(IE,IQ,NTARG)
9937 BNORM = XSPRO(IE,IQ,NTARG)
9940 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9941 IF ((IE.EQ.1).AND.(IQ.EQ.1))
9942 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9945 * write profile function data into file
9946 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9947 WRITE(LDAT,'(5I10,1P,E15.5)')
9948 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9949 WRITE(LDAT,'(1P,6E12.5)')
9950 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9951 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9952 WRITE(LDAT,'(1P,6E12.5)')
9953 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9954 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9955 NLINES = INT(DBLE(NSITEB)/7.0D0)
9956 IF (NLINES.GT.0) THEN
9959 WRITE(LDAT,'(1P,7E11.4)')
9960 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9964 IF (ISTART.LE.NSITEB) THEN
9965 WRITE(LDAT,'(1P,7E11.4)')
9966 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9972 C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9977 *===getbxs=============================================================*
9979 CDECK ID>, DT_GETBXS
9980 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9982 ************************************************************************
9983 * Biasing in impact parameter space. *
9984 * XSFRAC = 0 : BLO - minimum impact parameter (input) *
9985 * BHI - maximum impact parameter (input) *
9986 * XSFRAC - fraction of cross section corresponding *
9987 * to impact parameter range (BLO,BHI) *
9989 * XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
9990 * BHI - maximum impact parameter giving requested *
9991 * fraction of cross section in impact *
9992 * parameter range (0,BMAX) (output) *
9993 * This version dated 17.03.00 is written by S. Roesler *
9994 ************************************************************************
9996 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9999 PARAMETER ( LINP = 5 ,
10003 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10005 * Glauber formalism: parameters
10006 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10007 & BMAX(NCOMPX),BSTEP(NCOMPX),
10008 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10012 IF (XSFRAC.LE.0.0D0) THEN
10013 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10014 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10015 IF (ILO.GE.IHI) THEN
10019 IF (ILO.EQ.NSITEB-1) THEN
10020 FRCLO = BSITE(0,1,NTARG,NSITEB)
10022 FRCLO = BSITE(0,1,NTARG,ILO+1)
10023 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10024 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10026 IF (IHI.EQ.NSITEB-1) THEN
10027 FRCHI = BSITE(0,1,NTARG,NSITEB)
10029 FRCHI = BSITE(0,1,NTARG,IHI+1)
10030 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10031 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10033 XSFRAC = FRCHI-FRCLO
10038 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10039 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
10040 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10041 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10051 *===conucl=============================================================*
10053 CDECK ID>, DT_CONUCL
10054 SUBROUTINE DT_CONUCL(X,N,R,MODE)
10056 ************************************************************************
10057 * Calculation of coordinates of nucleons within nuclei. *
10058 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
10059 * N / R number of nucleons / radius of nucleus (input) *
10060 * MODE = 0 coordinates not sorted *
10061 * = 1 coordinates sorted with increasing X(3,i) *
10062 * = 2 coordinates sorted with decreasing X(3,i) *
10063 * This version dated 26.10.95 is revised by S. Roesler *
10064 ************************************************************************
10066 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10069 PARAMETER ( LINP = 5 ,
10073 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10074 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10076 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10078 PARAMETER (NSRT=10)
10079 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10080 DIMENSION X(3,N),XTMP(3,260)
10082 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10084 IF ((MODE.NE.0).AND.((N.EQ.3).OR.(N.GT.4))) THEN
10087 IF (MODE.EQ.2) THEN
10093 DO 2 J=1,ICSRT(ISRT)
10095 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10096 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10097 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10099 IF (ICSRT(ISRT).GT.1) THEN
10102 CALL DT_SORT(X,N,I0,I1,MODE)
10105 ELSEIF ((MODE.NE.0).AND.((N.EQ.2).OR.(N.EQ.4))) THEN
10111 CALL DT_SORT(X,N,1,N,MODE)
10123 *===coordi=============================================================*
10125 CDECK ID>, DT_COORDI
10126 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10128 ************************************************************************
10129 * Calculation of coordinates of nucleons within nuclei. *
10130 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
10131 * N / R number of nucleons / radius of nucleus (input) *
10132 * Based on the original version by Shmakov et al. *
10133 * This version dated 26.10.95 is revised by S. Roesler *
10134 ************************************************************************
10136 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10139 PARAMETER ( LINP = 5 ,
10143 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10144 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10146 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10150 PARAMETER (NSRT=10)
10151 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10152 DIMENSION X(3,260),WD(4),RD(3)
10154 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10155 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10156 DATA RD /2.09D0, 0.935D0, 0.697D0/
10166 ELSEIF (N.EQ.2) THEN
10167 EPS = DT_RNDM(RD(1))
10169 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10173 CALL DT_RANNOR(X1,X2)
10177 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10180 CALL DT_RANNOR(X3,X4)
10182 CALL DT_RANNOR(X1,X2)
10185 IF (LSTART) GOTO 80
10187 CALL DT_RANNOR(X3,X4)
10192 LSTART = .NOT.LSTART
10193 X1SUM = X1SUM+X(1,I)
10194 X2SUM = X2SUM+X(2,I)
10195 X3SUM = X3SUM+X(3,I)
10197 X1SUM = X1SUM/DBLE(N)
10198 X2SUM = X2SUM/DBLE(N)
10199 X3SUM = X3SUM/DBLE(N)
10201 X(1,I) = X(1,I)-X1SUM
10202 X(2,I) = X(2,I)-X2SUM
10203 X(3,I) = X(3,I)-X3SUM
10207 * maximum nuclear radius for coordinate sampling
10208 RMAX = R+4.605D0*PDIF
10210 * initialize pre-sorting
10214 DR = TWO*RMAX/DBLE(NSRT)
10216 * sample coordinates for N nucleons
10219 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10220 F = DT_DENSIT(N,RAD,R)
10221 IF (DT_RNDM(RAD).GT.F) GOTO 120
10222 * theta, phi uniformly distributed
10223 CT = ONE-TWO*DT_RNDM(F)
10224 ST = SQRT((ONE-CT)*(ONE+CT))
10225 CALL DT_DSFECF(SFE,CFE)
10226 X(1,I) = RAD*ST*CFE
10227 X(2,I) = RAD*ST*SFE
10229 * ensure that distance between two nucleons is greater than R2MIN
10230 IF (I.LT.2) GOTO 122
10233 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10234 & (X(3,I)-X(3,I2))**2
10235 IF (DIST2.LE.R2MIN) GOTO 120
10238 * save index according to z-bin
10239 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10240 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10241 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10242 X1SUM = X1SUM+X(1,I)
10243 X2SUM = X2SUM+X(2,I)
10244 X3SUM = X3SUM+X(3,I)
10246 X1SUM = X1SUM/DBLE(N)
10247 X2SUM = X2SUM/DBLE(N)
10248 X3SUM = X3SUM/DBLE(N)
10250 X(1,I) = X(1,I)-X1SUM
10251 X(2,I) = X(2,I)-X2SUM
10252 X(3,I) = X(3,I)-X3SUM
10260 *===densit=============================================================*
10262 CDECK ID>, DT_DENSIT
10263 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10265 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10268 PARAMETER ( LINP = 5 ,
10272 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10273 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10276 DIMENSION R0(18),FNORM(18)
10277 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10278 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10279 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10280 & 2.72D0, 2.66D0, 2.79D0/
10281 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10282 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10283 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10284 & .1214D+01,.1265D+01,.1318D+01/
10285 DATA PDIF /0.545D0/
10291 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10292 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10293 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10294 & *EXP(-(R/R1)**2)/FNORM(NA)
10296 ELSEIF (NA.GT.18) THEN
10297 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10303 *===rnclus=============================================================*
10305 CDECK ID>, DT_RNCLUS
10306 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10308 ************************************************************************
10309 * Nuclear radius for nucleus with mass number N. *
10310 * This version dated 26.9.00 is written by S. Roesler *
10311 ************************************************************************
10313 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10316 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10319 PARAMETER (RNUCLE = 1.12D0)
10321 * nuclear radii for selected nuclei
10322 DIMENSION RADNUC(18)
10323 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10324 & 2.58D0,2.71D0,2.66D0,2.71D0/
10327 IF (RADNUC(N).GT.0.0D0) THEN
10328 DT_RNCLUS = RADNUC(N)
10330 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10333 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10339 *===dentst=============================================================*
10341 C PROGRAM DT_DENTST
10342 CDECK ID>, DT_DENTST
10343 SUBROUTINE DT_DENTST
10345 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10348 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10349 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10354 DR = (RMAX-RMIN)/DBLE(NBINS)
10358 R = RMIN+DBLE(IR-1)*DR
10359 F = DT_DENSIT(IA,R,R)
10360 IF (F.GT.FMAX) FMAX = F
10361 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10363 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10371 *===shmaki=============================================================*
10373 CDECK ID>, DT_SHMAKI
10374 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10376 ************************************************************************
10377 * Initialisation of Glauber formalism. This subroutine has to be *
10378 * called once (in case of target emulsions as often as many different *
10379 * target nuclei are considered) before events are sampled. *
10380 * NA / NCA mass number/charge of projectile nucleus *
10381 * NB / NCB mass number/charge of target nucleus *
10382 * IJP identity of projectile (hadrons/leptons/photons) *
10383 * PPN projectile momentum (for projectile nuclei: *
10384 * momentum per nucleon) in target rest system *
10385 * MODE = 0 Glauber formalism invoked *
10386 * = 1 fitted results are loaded from data-file *
10387 * = 99 NTARG is forced to be 1 *
10388 * (used in connection with GLAUBERI-card only) *
10389 * This version dated 22.03.96 is based on the original SHMAKI-routine *
10390 * and revised by S. Roesler. *
10391 ************************************************************************
10393 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10396 PARAMETER ( LINP = 5 ,
10400 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10403 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10405 * Glauber formalism: parameters
10406 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10407 & BMAX(NCOMPX),BSTEP(NCOMPX),
10408 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10410 * Lorentz-parameters of the current interaction
10411 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10412 & UMO,PPCM,EPROJ,PPROJ
10413 * properties of photon/lepton projectiles
10414 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10415 * kinematical cuts for lepton-nucleus interactions
10416 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10417 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10418 * Glauber formalism: cross sections
10419 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10420 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10421 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10422 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10423 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10424 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10425 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10426 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10427 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10428 & BSLOPE,NEBINI,NQBINI
10429 * cuts for variable energy runs
10430 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10431 * nucleon-nucleon event-generator
10434 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10435 * Glauber formalism: flags and parameters for statistics
10438 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10440 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10446 IF (MODE.EQ.99) NTARG = 1
10448 IF (MODE.EQ.-1) NIDX = NTARG
10450 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10451 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10452 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10453 & ' initialization',/,12X,'--------------------------',
10454 & '-------------------------',/)
10456 IF (MODE.EQ.2) THEN
10457 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10458 CALL DT_SHFAST(MODE,PPN,IBACK)
10459 STOP ' Glauber pre-initialization done'
10461 IF (MODE.EQ.1) THEN
10462 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10465 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10466 IF (IBACK.EQ.1) THEN
10467 * lepton-nucleus (variable energy runs)
10468 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10469 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10470 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10471 & WRITE(LOUT,1002) NB,NCB
10472 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10473 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10474 & 'E_cm (GeV) Q^2 (GeV^2)',
10475 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10476 & '--------------------------------',
10477 & '------------------------------')
10478 AECMLO = LOG10(MIN(UMO,ECMLI))
10479 AECMHI = LOG10(MIN(UMO,ECMHI))
10481 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10482 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10484 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10485 IF (Q2HI.GT.0.1D0) THEN
10486 IF (Q2LI.LT.0.01D0) THEN
10487 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10488 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10490 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10497 AQ2LO = LOG10(Q2LI)
10498 AQ2HI = LOG10(Q2HI)
10499 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10500 DO 2 J=IBIN,IQSTEP+IBIN
10501 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10502 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10503 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10504 & WRITE(LOUT,1003) ECMNN(I),
10505 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10508 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10509 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10511 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10513 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10517 * hadron/photon/nucleus-nucleus
10518 IF ((ABS(VAREHI).GT.ZERO).AND.
10519 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10520 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10521 WRITE(LOUT,1004) NA,NB,NCB
10522 1004 FORMAT(1X,'variable energy run: projectile-id:',
10523 & I3,' target A/Z: ',I3,' /',I3,/)
10525 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10526 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10527 & ' -------------------------------------',
10528 & '--------------------------------------')
10530 AECMLO = LOG10(VARCLO)
10531 AECMHI = LOG10(VARCHI)
10533 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10534 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10536 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10541 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10542 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10543 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10544 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10546 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10547 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10551 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10557 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10558 & (IOGLB.NE.100)) THEN
10559 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10560 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10561 1001 FORMAT(38X,'projectile',
10562 & ' target',/,1X,'Mass number / charge',
10563 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10564 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10565 & 'Parameters of elastic scattering amplitude:',/,5X,
10566 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10567 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10568 & 'statistics at each b-step',4X,I5,/,/,1X,
10569 & 'Prod. cross section ',5X,F10.4,' mb',/)
10575 *===profbi=============================================================*
10577 CDECK ID>, DT_PROFBI
10578 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10580 ************************************************************************
10581 * Integral over profile function (to be used for impact-parameter *
10582 * sampling during event generation). *
10583 * Fitted results are used. *
10584 * NA / NB mass numbers of proj./target nuclei *
10585 * PPN projectile momentum (for projectile nuclei: *
10586 * momentum per nucleon) in target rest system *
10587 * NTARG index of target material (i.e. kind of nucleus) *
10588 * This version dated 31.05.95 is revised by S. Roesler *
10589 ************************************************************************
10591 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10594 PARAMETER ( LINP = 5 ,
10600 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10605 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10607 * Glauber formalism: parameters
10608 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10609 & BMAX(NCOMPX),BSTEP(NCOMPX),
10610 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10612 * Glauber formalism: cross sections
10613 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10614 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10615 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10616 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10617 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10618 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10619 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10620 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10621 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10622 & BSLOPE,NEBINI,NQBINI
10624 PARAMETER (NGLMAX=8000)
10625 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10626 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10628 DATA LSTART /.TRUE./
10631 * read fit-parameters from file
10632 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10635 READ(47,'(A80)') CNAME
10636 IF (CNAME.EQ.'STOP') GOTO 2
10638 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10639 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10640 & GLAFIT(4,I),GLAFIT(5,I)
10641 IF (I+1.GT.NGLMAX) THEN
10643 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
10644 & 'program stopped')
10661 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10662 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10665 IF (J.EQ.NGLPAR) IPOINT = J+1-K
10666 IF ((NNA.GT.NGLIP(IPOINT)).OR.
10667 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10668 IF (IPOINT.EQ.1) IPOINT = 0
10669 NATMP = NGLIP(IPOINT+1)
10670 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10676 C IF (J.EQ.NGLPAR) THEN
10680 DO 5 J1=J1BEG,J1END
10681 IF (NGLIP(J1).EQ.NATMP) THEN
10682 IF (PPN.LT.GLAPPN(J1)) THEN
10691 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10700 IF (IDXGLA.EQ.0) THEN
10701 WRITE(LOUT,1001) NNA,NNB,PPN
10702 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
10703 & 2I4,F6.0,') not found ')
10707 * no interpolation yet available
10708 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10710 BSITE(1,1,NTARG,1) = ZERO
10713 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10714 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10715 & GLAFIT(5,IDXGLA)*XX**4
10716 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10717 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10718 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10724 *===glaube=============================================================*
10726 CDECK ID>, DT_GLAUBE
10727 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10729 ************************************************************************
10730 * Calculation of configuartion of interacting nucleons for one event. *
10731 * NA / NB mass numbers of proj./target nuclei (input) *
10732 * B impact parameter (output) *
10733 * INTT total number of wounded nucleons " *
10734 * INTA / INTB number of wounded nucleons in proj. / target " *
10735 * JS / JT(i) number of collisions proj. / target nucleon i is *
10736 * involved (output) *
10737 * NIDX index of projectile/target material (input)*
10738 * This is an update of the original routine SHMAKO by J.Ranft/HJM *
10739 * This version dated 22.03.96 is revised by S. Roesler *
10740 ************************************************************************
10742 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10745 PARAMETER ( LINP = 5 ,
10749 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10750 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10752 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10754 PARAMETER ( MAXNCL = 260,
10757 & MAXSQU = 20*MAXVQU,
10758 & MAXINT = MAXVQU+MAXSQU)
10759 * Glauber formalism: parameters
10760 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10761 & BMAX(NCOMPX),BSTEP(NCOMPX),
10762 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10764 * Glauber formalism: cross sections
10765 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10766 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10767 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10768 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10769 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10770 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10771 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10772 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10773 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10774 & BSLOPE,NEBINI,NQBINI
10775 * Lorentz-parameters of the current interaction
10776 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10777 & UMO,PPCM,EPROJ,PPROJ
10778 * properties of photon/lepton projectiles
10779 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10780 * Glauber formalism: collision properties
10781 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10782 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10783 * Glauber formalism: flags and parameters for statistics
10786 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10788 DIMENSION JS(MAXNCL),JT(MAXNCL)
10792 * get actual energy from /DTLTRA/
10796 * new patch for pre-initialized variable projectile/target/energy runs
10797 IF (IOGLB.EQ.100) THEN
10798 CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10800 * variable energy run, interpolate profile function
10805 IF (NEBINI.GT.1) THEN
10806 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10810 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10812 IF (ECMNOW.LT.ECMNN(I)) THEN
10815 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10825 IF (NQBINI.GT.1) THEN
10826 IF (Q2.GE.Q2G(NQBINI)) THEN
10830 ELSEIF (Q2.GT.Q2G(1)) THEN
10832 IF (Q2.LT.Q2G(I)) THEN
10835 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
10836 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10837 C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10846 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10847 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10848 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10849 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10850 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10854 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10855 IF (NIDX.LE.-1) THEN
10857 RTARG = RBSH(NTARG)
10859 RPROJ = RASH(NTARG)
10866 *===diagr==============================================================*
10868 CDECK ID>, DT_DIAGR
10869 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10872 ************************************************************************
10873 * Based on the original version by Shmakov et al. *
10874 * This version dated 21.04.95 is revised by S. Roesler *
10875 ************************************************************************
10877 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10880 PARAMETER ( LINP = 5 ,
10884 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10885 PARAMETER (TWOPI = 6.283185307179586454D+00,
10887 & GEV2MB = 0.38938D0,
10888 & GEV2FM = 0.1972D0,
10889 & ALPHEM = ONE/137.0D0,
10898 PARAMETER ( MAXNCL = 260,
10901 & MAXSQU = 20*MAXVQU,
10902 & MAXINT = MAXVQU+MAXSQU)
10903 * particle properties (BAMJET index convention)
10905 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10906 & IICH(210),IIBAR(210),K1(210),K2(210)
10908 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10910 * emulsion treatment
10911 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10913 * Glauber formalism: parameters
10914 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10915 & BMAX(NCOMPX),BSTEP(NCOMPX),
10916 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10918 * Glauber formalism: cross sections
10919 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10920 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10921 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10922 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10923 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10924 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10925 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10926 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10927 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10928 & BSLOPE,NEBINI,NQBINI
10929 * VDM parameter for photon-nucleus interactions
10930 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10931 * nucleon-nucleon event-generator
10934 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10936 C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10938 C obsolete cut-off information
10939 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10940 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10942 * coordinates of nucleons
10943 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10944 * interface between Glauber formalism and DPM
10945 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10946 & INTER1(MAXINT),INTER2(MAXINT)
10947 * statistics: Glauber-formalism
10948 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10949 * n-n cross section fluctuations
10950 PARAMETER (NBINS = 1000)
10951 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10953 DIMENSION JS(MAXNCL),JT(MAXNCL),
10954 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10955 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10956 DIMENSION NWA(0:210),NWB(0:210)
10959 DATA LFIRST /.TRUE./
10961 DATA NTARGO,ICNT /0,0/
10967 IF (NCOMPO.EQ.0) THEN
10977 IF (NTARG.EQ.-1) THEN
10978 IF (NCOMPO.EQ.0) THEN
10979 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10980 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10981 & NCALL,NWAMAX,NWBMAX
10982 DO 18 I=1,MAX(NWAMAX,NWBMAX)
10983 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10984 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10985 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10995 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10997 X = SQ2/(S+SQ2-AMP2)
10998 XNU = (S+SQ2-AMP2)/(TWO*AMP)
10999 * photon projectiles: recalculate photon-nucleon amplitude
11000 IF (IJPROJ.EQ.7) THEN
11002 * VDM assumption: mass of V-meson
11003 AMV2 = DT_SAM2(SQ2,ECMNOW)
11005 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11006 * check for pointlike interaction
11007 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11009 C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11010 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11013 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11014 & +0.25D0*LOG(S/(AMV2+SQ2)))
11016 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11017 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11018 IF (MCGENE.EQ.2) THEN
11020 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11023 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11025 IF (ECMNOW.LE.3.0D0) THEN
11027 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11028 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11029 ELSEIF (ECMNOW.GT.50.0D0) THEN
11032 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11033 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11034 IF (MCGENE.EQ.2) THEN
11036 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11038 SIGSH = SIGSH/10.0D0
11040 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11042 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11043 SIGSH = SIGSH/10.0D0
11046 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11048 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11049 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11050 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11052 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11053 SIGSH = SIGSH/10.0D0
11055 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11057 RCA = GAM*SIGSH/TWOPI
11059 CA = DCMPLX(RCA,FCA)
11060 CI = DCMPLX(ONE,ZERO)
11064 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11077 IF (IJPROJ.EQ.7) THEN
11087 * nucleon configuration
11088 C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11089 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11090 C CALL DT_CONUCL(PKOO,NA,RASH,2)
11091 C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11092 IF (NIDX.LE.-1) THEN
11093 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11094 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11096 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11097 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11103 * LEPTO: pick out one struck nucleon
11104 IF (MCGENE.EQ.3) THEN
11107 IDX = INT(DT_RNDM(X)*NB)+1
11114 * cross section fluctuations
11116 IF (IFLUCT.EQ.1) THEN
11117 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11118 AFLUC = FLUIXX(IFLUK)
11123 * photon-projectile: check for supression by coherence length
11124 IF (IJPROJ.EQ.7) THEN
11125 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11130 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11131 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11132 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11133 IF (XY.LE.15.0D0) THEN
11134 C = CI-CA*AFLUC*EXP(-XY)
11138 IF (DT_RNDM(XY).GE.P) THEN
11140 IF (IJPROJ.EQ.7) THEN
11141 JNT0(KINT) = JNT0(KINT)+1
11142 IF (JNT0(KINT).GT.MAXNCL) THEN
11143 WRITE(LOUT,1001) MAXNCL
11145 & 'DIAGR: no. of requested interactions',
11146 & ' exceeds array dimensions ',I4)
11149 JS0(KINT) = JS0(KINT)+1
11150 JT0(KINT,INB) = JT0(KINT,INB)+1
11151 JI1(KINT,JNT0(KINT)) = INA
11152 JI2(KINT,JNT0(KINT)) = INB
11154 IF (JNT.GT.MAXINT) THEN
11155 WRITE(LOUT,1000) JNT, MAXINT
11157 & 'DIAGR: no. of requested interactions ('
11158 & ,I4,') exceeds array dimensions (',I4,')')
11161 JS(INA) = JS(INA)+1
11162 JT(INB) = JT(INB)+1
11172 IF (NTRY.LT.500) THEN
11175 C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11181 IF (IJPROJ.EQ.7) THEN
11182 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11184 IF (JNT0(K).EQ.0) THEN
11186 IF (K.GT.KINT) K = 1
11189 * supress Glauber-cascade by direct photon processes
11190 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11191 IF (IPNT.GT.0) THEN
11195 JT(INB) = JT0(K,INB)
11196 IF (JT(INB).GT.0) GOTO 12
11206 JT(INB) = JT0(K,INB)
11209 INTER1(I) = JI1(K,I)
11210 INTER2(I) = JI2(K,I)
11219 IF (JS(I).NE.0) INTA=INTA+1
11222 IF (JT(I).NE.0) INTB=INTB+1
11231 IF (NCOMPO.EQ.0) THEN
11233 NWA(INTA) = NWA(INTA)+1
11234 NWB(INTB) = NWB(INTB)+1
11240 *===modb===============================================================*
11243 SUBROUTINE DT_MODB(B,NIDX)
11245 ************************************************************************
11246 * Sampling of impact parameter of collision. *
11247 * B impact parameter (output) *
11248 * NIDX index of projectile/target material (input)*
11249 * Based on the original version by Shmakov et al. *
11250 * This version dated 21.04.95 is revised by S. Roesler *
11251 ************************************************************************
11253 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11256 PARAMETER ( LINP = 5 ,
11260 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11262 LOGICAL LEFT,LFIRST
11264 * central particle production, impact parameter biasing
11265 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11267 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11269 * Glauber formalism: parameters
11270 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11271 & BMAX(NCOMPX),BSTEP(NCOMPX),
11272 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11274 * Glauber formalism: cross sections
11275 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11276 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11277 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11278 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11279 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11280 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11281 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11282 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11283 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11284 & BSLOPE,NEBINI,NQBINI
11286 DATA LFIRST /.TRUE./
11289 IF (NIDX.LE.-1) THEN
11297 IF (ICENTR.EQ.2) THEN
11299 BB = DT_RNDM(B)*(0.3D0*RA)**2
11301 ELSEIF(RA.LT.RB)THEN
11302 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11304 ELSEIF(RA.GT.RB)THEN
11305 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11315 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11316 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11323 IF (I2-I0-2) 40,50,60
11326 IF (I1.GT.NSITEB) I1 = I0-1
11334 X0 = DBLE(I0-1)*BSTEP(NTARG)
11335 X1 = DBLE(I1-1)*BSTEP(NTARG)
11336 X2 = DBLE(I2-1)*BSTEP(NTARG)
11337 Y0 = BSITE(0,1,NTARG,I0)
11338 Y1 = BSITE(0,1,NTARG,I1)
11339 Y2 = BSITE(0,1,NTARG,I2)
11341 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11342 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11343 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11344 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11345 B = B+0.5D0*BSTEP(NTARG)
11346 IF (B.LT.ZERO) B = X1
11347 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11348 IF (ICENTR.LT.0) THEN
11351 IF (ICENTR.LE.-100) THEN
11356 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11357 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11358 & BIMIN,BIMAX,XSFRAC*100.0D0,
11359 & XSFRAC*XSPRO(1,1,NTARG)
11360 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11361 & /,15X,'---------------------------'/,/,4X,
11362 & 'average radii of proj / targ :',F10.3,' fm /',
11363 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11364 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11365 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11366 & ' cross section :',F10.3,' %',/,5X,
11367 & 'corresponding cross section :',F10.3,' mb',/)
11369 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11372 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11380 *===shfast=============================================================*
11382 CDECK ID>, DT_SHFAST
11383 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11385 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11388 PARAMETER ( LINP = 5 ,
11392 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11393 & ONE=1.0D0,TWO=2.0D0)
11395 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11397 * Glauber formalism: parameters
11398 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11399 & BMAX(NCOMPX),BSTEP(NCOMPX),
11400 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11402 * properties of interacting particles
11403 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11404 * Glauber formalism: cross sections
11405 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11406 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11407 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11408 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11409 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11410 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11411 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11412 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11413 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11414 & BSLOPE,NEBINI,NQBINI
11418 IF (MODE.EQ.2) THEN
11419 OPEN(47,FILE='shmakov.out',STATUS='UNKNOWN')
11420 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11421 1000 FORMAT(1X,8I5,E15.5)
11422 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11423 1001 FORMAT(1X,4E15.5)
11424 WRITE(47,1002) SIGSH,ROSH,GSH
11425 1002 FORMAT(1X,3E15.5)
11427 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11429 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11430 1003 FORMAT(1X,2I10,3E15.5)
11433 OPEN(47,FILE='shmakov.out',STATUS='UNKNOWN')
11434 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11435 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11436 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11437 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11438 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11439 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11440 READ(47,1002) SIGSH,ROSH,GSH
11442 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11444 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11454 *===poilik=============================================================*
11456 CDECK ID>, DT_POILIK
11457 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11459 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11462 PARAMETER ( LINP = 5 ,
11466 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11470 C CHARACTER*8 MDLNA
11471 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11472 C PARAMETER (IEETAB=10)
11473 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11475 C model switches and parameters
11477 INTEGER ISWMDL,IPAMDL
11478 DOUBLE PRECISION PARMDL
11479 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11480 C energy-interpolation table
11482 PARAMETER ( IEETA2 = 20 )
11484 DOUBLE PRECISION SIGTAB,SIGECM
11485 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11487 * VDM parameter for photon-nucleus interactions
11488 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11491 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11493 * Glauber formalism: cross sections
11494 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11495 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11496 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11497 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11498 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11499 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11500 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11501 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11502 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11503 & BSLOPE,NEBINI,NQBINI
11506 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11508 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11510 * load cross sections from interpolation table
11512 IF(ECM.LE.SIGECM(IP,1)) THEN
11515 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11517 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11523 WRITE(LOUT,'(/1X,A,2E12.3)')
11524 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11529 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11530 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11533 SIGANO = DT_SANO(ECM)
11535 * cross section dependence on photon virtuality
11538 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11539 & /(ONE+VIRT/PARMDL(30+I))**2
11541 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11551 C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11552 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11553 IF (ISHAD(1).EQ.1) THEN
11554 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11558 SIGANO = FSUP1*FSUP2*SIGANO
11559 SIGTOT = SIGTOT-SIGDIR-SIGANO
11560 SIGDIR = SIGDIR/(FSUP1*FSUP2)
11561 SIGANO = SIGANO/(FSUP1*FSUP2)
11562 SIGTOT = SIGTOT+SIGDIR+SIGANO
11564 RR = DT_RNDM(SIGTOT)
11565 IF (RR.LT.SIGDIR/SIGTOT) THEN
11567 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11568 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11573 RPNT = (SIGDIR+SIGANO)/SIGTOT
11574 C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11575 C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11576 C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11577 C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11578 IF (MODE.EQ.1) RETURN
11584 IF (ECM.GE.ECMNN(NEBINI)) THEN
11588 ELSEIF (ECM.GT.ECMNN(1)) THEN
11590 IF (ECM.LT.ECMNN(I)) THEN
11593 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11602 IF (NQBINI.GT.1) THEN
11603 IF (VIRT.GE.Q2G(NQBINI)) THEN
11607 ELSEIF (VIRT.GT.Q2G(1)) THEN
11609 IF (VIRT.LT.Q2G(I)) THEN
11612 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
11613 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11620 SGA = XSPRO(K1,J1,NTARG)+
11621 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11622 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11623 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11624 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11625 SDI = DBLE(NB)*SIGDIR
11626 SAN = DBLE(NB)*SIGANO
11629 IF (RR.LT.SDI/SGA) THEN
11631 ELSEIF ((RR.GE.SDI/SGA).AND.
11632 & (RR.LT.SPL/SGA)) THEN
11638 C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11644 *===glbini=============================================================*
11646 CDECK ID>, DT_GLBINI
11647 SUBROUTINE DT_GLBINI(WHAT)
11649 ************************************************************************
11650 * Pre-initialization of profile function *
11651 * This version dated 28.11.00 is written by S. Roesler. *
11652 ************************************************************************
11654 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11657 PARAMETER ( LINP = 5 ,
11661 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11665 * particle properties (BAMJET index convention)
11667 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11668 & IICH(210),IIBAR(210),K1(210),K2(210)
11669 * properties of interacting particles
11670 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11672 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11674 * emulsion treatment
11675 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11677 * Glauber formalism: flags and parameters for statistics
11680 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11681 * number of data sets other than protons and nuclei
11682 * at the moment = 2 (pions and kaons)
11683 PARAMETER (MAXOFF=2)
11684 DIMENSION IJPINI(5),IOFFST(25)
11685 DATA IJPINI / 13, 15, 0, 0, 0/
11686 * Glauber data-set to be used for hadron projectiles
11687 * (0=proton, 1=pion, 2=kaon)
11688 DATA (IOFFST(K),K=1,25) /
11689 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11691 * Acceptance interval for target nucleus mass
11692 PARAMETER (KBACC = 6)
11694 PARAMETER (MAXMSS = 100)
11695 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11698 DATA JPEACH,JPSTEP / 18, 5 /
11700 * temporary patch until fix has been implemented in phojet:
11701 * maximum energy for pion projectile
11702 DATA ECMXPI / 100000.0D0 /
11704 *--------------------------------------------------------------------------
11705 * general initializations
11707 * steps in projectile mass number for initialization
11708 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11709 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11711 * energy range and binning
11714 IF (ELO.GT.EHI) ELO = EHI
11715 NEBIN = MAX(INT(WHAT(3)),1)
11716 IF (ELO.EQ.EHI) NEBIN = 0
11717 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11721 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11722 & +2.0D0*AAM(IJTARG)*EHI)
11725 * default arguments for Glauber-routine
11729 * initialize nuclear parameters, etc.
11735 * open Glauber-data output file
11736 IDX = INDEX(CGLB,' ')
11738 IF (IDX.GT.1) K = IDX-1
11739 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11741 *--------------------------------------------------------------------------
11742 * Glauber-initialization for proton and nuclei projectiles
11744 * initialize phojet for proton-proton interactions
11747 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11750 * record projectile masses
11752 NPROJ = MIN(IP,JPEACH)
11753 DO 10 KPROJ=1,NPROJ
11755 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11756 IASAV(NASAV) = KPROJ
11758 IF (IP.GT.JPEACH) THEN
11759 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11760 IF (NPROJ.EQ.0) THEN
11762 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11765 DO 11 IPROJ=1,NPROJ
11766 KPROJ = JPEACH+IPROJ*JPSTEP
11768 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11769 IASAV(NASAV) = KPROJ
11771 IF (KPROJ.LT.IP) THEN
11773 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11779 * record target masses
11782 IF (NCOMPO.GT.0) NTARG = NCOMPO
11783 DO 12 ITARG=1,NTARG
11785 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11786 IF (NCOMPO.GT.0) THEN
11787 IBSAV(NBSAV) = IEMUMA(ITARG)
11794 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11795 1000 FORMAT(I4,A,1P,2E13.5)
11796 NLINES = DBLE(NASAV)/18.0D0
11797 IF (NLINES.GT.0) THEN
11800 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11802 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11807 IF (I0.LE.NASAV) THEN
11809 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11811 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11814 NLINES = DBLE(NBSAV)/18.0D0
11815 IF (NLINES.GT.0) THEN
11818 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11820 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11825 IF (I0.LE.NBSAV) THEN
11827 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11829 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11833 * calculate Glauber-data for each energy and mass combination
11835 * loop over energy bins
11838 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11840 E = ELO+DBLE(IE-1)*DEBIN
11843 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11848 E = MAX(AAM(IJPROJ)+0.1D0,E)
11849 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11852 * loop over projectile and target masses
11855 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11856 & XI,Q2I,ECM,1,1,-1)
11862 *--------------------------------------------------------------------------
11863 * Glauber-initialization for pion, kaon, ... projectiles
11867 * initialize phojet for this interaction
11870 IJPROJ = IJPINI(IJ)
11874 * temporary patch until fix has been implemented in phojet:
11875 IF (ECMINI.GT.ECMXPI) THEN
11876 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11878 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11882 * calculate Glauber-data for each energy and mass combination
11884 * loop over energy bins
11886 E = ELO+DBLE(IE-1)*DEBIN
11889 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11894 E = MAX(AAM(IJPROJ)+TINY14,E)
11895 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11898 * loop over projectile and target masses
11900 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11907 *--------------------------------------------------------------------------
11908 * close output unit(s), etc.
11915 *===glbset=============================================================*
11917 CDECK ID>, DT_GLBSET
11918 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11919 ************************************************************************
11920 * Interpolation of pre-initialized profile functions *
11921 * This version dated 28.11.00 is written by S. Roesler. *
11922 ************************************************************************
11924 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11927 PARAMETER ( LINP = 5 ,
11931 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11933 LOGICAL LCMS,LREAD,LFRST1,LFRST2
11935 * particle properties (BAMJET index convention)
11937 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11938 & IICH(210),IIBAR(210),K1(210),K2(210)
11939 * Glauber formalism: flags and parameters for statistics
11942 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11944 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11946 * Glauber formalism: parameters
11947 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11948 & BMAX(NCOMPX),BSTEP(NCOMPX),
11949 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11951 * Glauber formalism: cross sections
11952 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11953 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11954 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11955 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11956 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11957 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11958 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11959 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11960 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11961 & BSLOPE,NEBINI,NQBINI
11962 * number of data sets other than protons and nuclei
11963 * at the moment = 2 (pions and kaons)
11964 PARAMETER (MAXOFF=2)
11965 DIMENSION IJPINI(5),IOFFST(25)
11966 DATA IJPINI / 13, 15, 0, 0, 0/
11967 * Glauber data-set to be used for hadron projectiles
11968 * (0=proton, 1=pion, 2=kaon)
11969 DATA (IOFFST(K),K=1,25) /
11970 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11972 * Acceptance interval for target nucleus mass
11973 PARAMETER (KBACC = 6)
11974 * emulsion treatment
11975 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11978 PARAMETER (MAXSET=5000,
11980 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11981 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11982 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11985 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11987 * read data from file
11989 IF (MODE.EQ.0) THEN
12012 IDX = INDEX(CGLB,' ')
12014 IF (IDX.GT.1) K = IDX-1
12015 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12016 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12017 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
12020 * read binning information
12021 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12022 * return lower energy threshold to Fluka-interface
12025 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12027 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12029 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12031 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
12032 & 'No. of bins:',I5,/)
12033 ELO = LOG10(ABS(ELO))
12034 EHI = LOG10(ABS(EHI))
12035 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12036 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12037 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12038 IF (NABIN.LT.18) THEN
12039 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12041 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12043 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12044 IF (NABIN.GT.18) THEN
12045 NLINES = DBLE(NABIN-18)/18.0D0
12046 IF (NLINES.GT.0) THEN
12049 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12050 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12053 I0 = 18*(NLINES+1)+1
12054 IF (I0.LE.NABIN) THEN
12055 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12056 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12059 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12060 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12061 IF (NBBIN.LT.18) THEN
12062 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12064 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12066 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12067 IF (NBBIN.GT.18) THEN
12068 NLINES = DBLE(NBBIN-18)/18.0D0
12069 IF (NLINES.GT.0) THEN
12072 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12073 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12076 I0 = 18*(NLINES+1)+1
12077 IF (I0.LE.NBBIN) THEN
12078 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12079 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12082 * number of data sets to follow in the Glauber data file
12083 * this variable is used for checks of consistency of projectile
12084 * and target mass configurations given in header of Glauber data
12085 * file and the data-sets which follow in this file
12086 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12088 * read profile function data
12094 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12095 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12096 1002 FORMAT(5I10,E15.5)
12097 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12099 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12103 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12104 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12105 NLINES = INT(DBLE(ISITEB)/7.0D0)
12106 IF (NLINES.GT.0) THEN
12108 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12113 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12117 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12118 WRITE(LOUT,'(/,1X,A)')
12119 & ' projectiles other than protons and nuclei: (particle index)'
12120 IF (NAIDX.GT.0) THEN
12121 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12123 WRITE(LOUT,'(6X,A)') 'none'
12130 IF (NCOMPO.EQ.0) THEN
12133 IEMUMA(NCOMPO) = IBBIN(J)
12134 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12135 EMUFRA(NCOMPO) = 1.0D0
12140 * calculate profile function for certain set of parameters
12144 c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12146 * check for type of projectile and set index-offset to entry in
12147 * Glauber data array correspondingly
12148 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12149 IF (IOFFST(IDPROJ).EQ.-1) THEN
12150 STOP ' GLBSET: no data for this projectile !'
12151 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12152 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12157 * get energy bin and interpolation factor
12159 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12166 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12173 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12178 IE0 = (E-ELO)/DEBIN+1
12180 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12182 * get target nucleus index
12186 NBDIFF = ABS(NB-IBBIN(I))
12187 IF (NB.EQ.IBBIN(I)) THEN
12190 ELSEIF (NBDIFF.LE.NBACC) THEN
12195 IF (KB.NE.0) GOTO 21
12196 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12200 * get projectile nucleus bin and interpolation factor
12204 IF (IDXOFF.GT.0) THEN
12209 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12211 IF (NA.EQ.IABIN(I)) THEN
12215 ELSEIF (NA.LT.IABIN(I)) THEN
12221 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12225 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12229 * interpolate profile functions for interactions ka0-kb and ka1-kb
12230 * for energy E separately
12231 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12232 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12233 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12234 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12236 BPRO0(I) = BPROFL(IDX0,I)
12237 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12238 BPRO1(I) = BPROFL(IDY0,I)
12239 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12241 RADB = DT_RNCLUS(NB)
12242 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12243 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12245 * interpolate cross sections for energy E and projectile mass
12247 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12248 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12249 XS(I) = XS0+FACNA*(XS1-XS0)
12250 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12251 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12252 XE(I) = XE0+FACNA*(XE1-XE0)
12255 * interpolate between ka0 and ka1
12256 RADA = DT_RNCLUS(NA)
12257 BMX = 2.0D0*(RADA+RADB)
12258 BSTP = BMX/DBLE(ISITEB-1)
12263 * calculate values of profile functions at B
12265 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12266 IDX1 = MIN(IDX0+1,ISITEB)
12267 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12268 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12270 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12271 IDX1 = MIN(IDX0+1,ISITEB)
12272 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12273 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12275 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12278 * fill common dtglam
12285 BSITE(0,1,1,I) = BPRO(I)
12288 * fill common dtglxs
12289 XSTOT(1,1,1) = XS(1)
12290 XSELA(1,1,1) = XS(2)
12291 XSQEP(1,1,1) = XS(3)
12292 XSQET(1,1,1) = XS(4)
12293 XSQE2(1,1,1) = XS(5)
12294 XSPRO(1,1,1) = XS(6)
12295 XETOT(1,1,1) = XE(1)
12296 XEELA(1,1,1) = XE(2)
12297 XEQEP(1,1,1) = XE(3)
12298 XEQET(1,1,1) = XE(4)
12299 XEQE2(1,1,1) = XE(5)
12300 XEPRO(1,1,1) = XE(6)
12307 *===xksamp=============================================================*
12309 CDECK ID>, DT_XKSAMP
12310 SUBROUTINE DT_XKSAMP(NN,ECM)
12312 ************************************************************************
12313 * Sampling of parton x-values and chain system for one interaction. *
12314 * processed by S. Roesler, 9.8.95 *
12315 ************************************************************************
12317 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12320 PARAMETER ( LINP = 5 ,
12324 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12328 * lower cuts for (valence-sea/sea-valence) chain masses
12329 * antiquark-quark (u/d-sea quark) (s-sea quark)
12330 & AMIU = 0.5D0, AMIS = 0.8D0,
12331 * quark-diquark (u/d-sea quark) (s-sea quark)
12332 & AMAU = 2.6D0, AMAS = 2.6D0,
12333 * maximum lower valence-x threshold
12335 * fraction of sea-diquarks sampled out of sea-partons
12337 C & FRCDIQ = 0.9D0,
12342 * maximum number of trials to generate x's for the required number
12343 * of sea quark pairs for a given hadron
12348 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12350 PARAMETER ( MAXNCL = 260,
12353 & MAXSQU = 20*MAXVQU,
12354 & MAXINT = MAXVQU+MAXSQU)
12357 PARAMETER (NMXHKK=200000)
12359 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12360 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12361 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12362 * particle properties (BAMJET index convention)
12364 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12365 & IICH(210),IIBAR(210),K1(210),K2(210)
12366 * interface between Glauber formalism and DPM
12367 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12368 & INTER1(MAXINT),INTER2(MAXINT)
12369 * properties of interacting particles
12370 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12371 * threshold values for x-sampling (DTUNUC 1.x)
12372 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12374 * x-values of partons (DTUNUC 1.x)
12375 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12376 & XTVQ(MAXVQU),XTVD(MAXVQU),
12377 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12378 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12379 * flavors of partons (DTUNUC 1.x)
12380 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12381 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12382 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12383 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12384 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12385 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12386 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12387 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12388 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12389 & IXPV,IXPS,IXTV,IXTS,
12390 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12391 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12392 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12393 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12394 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12395 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12396 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12397 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12398 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12399 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12400 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12401 * auxiliary common for chain system storage (DTUNUC 1.x)
12402 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12403 * flags for input different options
12404 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12405 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12406 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12407 * various options for treatment of partons (DTUNUC 1.x)
12408 * (chain recombination, Cronin,..)
12409 LOGICAL LCO2CR,LINTPT
12410 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12413 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12416 * (1) initializations
12417 *-----------------------------------------------------------------------
12420 IF (ECM.LT.4.5D0) THEN
12423 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12424 C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12425 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12434 IF (I.LE.MAXVQU) THEN
12440 * lower thresholds for x-selection
12441 * sea-quarks (default: CSEA=0.2)
12442 IF (ECM.LT.10.0D0) THEN
12444 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12445 C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12447 C XSTHR = ONE/ECM**2
12451 XSTHR = CSEA/ECM**2
12452 C XSTHR = ONE/ECM**2
12454 IF ((IP.GE.150).AND.(IT.GE.150))
12455 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12458 * (default: SSMIMA=0.14) used for sea-diquarks (?)
12459 XSSTHR = SSMIMA/ECM
12461 * valence-quarks (default: CVQ=1.0)
12463 * valence-diquarks (default: CDQ=2.0)
12466 * maximum-x for sea-quarks
12467 XVCUT = XVTHR+XDTHR
12468 IF (XVCUT.GT.XVMAX) THEN
12470 XVTHR = XVCUT/3.0D0
12471 XDTHR = XVCUT-XVTHR
12474 **sr 18.4. test: DPMJET
12475 C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12476 C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12477 C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12479 * maximum number of sea-pairs allowed kinematically
12480 C NSMAX = INT(OHALF*XXSEAM/XSTHR)
12481 RNSMAX = OHALF*XXSEAM/XSTHR
12482 IF (RNSMAX.GT.10000.0D0) THEN
12485 NSMAX = INT(OHALF*XXSEAM/XSTHR)
12487 * check kinematical limit for valence-x thresholds
12488 * (should be obsolete now)
12489 IF (XVCUT.GT.XVMAX) THEN
12490 WRITE(LOUT,1000) XVCUT,ECM
12491 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
12492 & ' thresholds not allowed (',2E9.3,')')
12493 C XVTHR = XVMAX-XDTHR
12494 C IF (XVTHR.LT.ZERO) STOP
12498 * set eta for valence-x sampling (BETREJ)
12499 * (UNON per default, UNOM used for projectile mesons only)
12500 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12506 * (2) select parton x-values of interacting projectile nucleons
12507 *-----------------------------------------------------------------------
12513 * get interacting projectile nucleon as sampled by Glauber
12514 IF (JSSH(IPP).NE.0) THEN
12520 * JIPP is the actual number of sea-pairs sampled for this nucleon
12521 JIPP = MIN(JSSH(IPP)-1,NSMAX)
12524 IF (JIPP.GT.0) THEN
12525 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12527 IF (XSTHR.GE.XSMAX) THEN
12532 *>>>get x-values of sea-quark pairs
12536 * accumulator for sea x-values
12539 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12540 IF (NSCOUN.GT.NSEA) THEN
12541 * decrease the number of interactions after NSEA trials
12547 IF (IPSQ(IXPS+1).LE.2) THEN
12548 **sr 8.4.98 (1/sqrt(x))
12549 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12550 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12551 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12554 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12555 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12557 **sr 8.4.98 (1/sqrt(x))
12558 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12559 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12560 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12565 IF (IPSAQ(IXPS+1).GE.-2) THEN
12566 **sr 8.4.98 (1/sqrt(x))
12567 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12568 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12569 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12572 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12573 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12575 **sr 8.4.98 (1/sqrt(x))
12576 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12577 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12578 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12582 XXSEA = XXSEA+XPSQI+XPSAQI
12583 * check for maximum allowed sea x-value
12584 IF (XXSEA.GE.XXSEAM) THEN
12588 * accept this sea-quark pair
12591 XPSAQ(IXPS) = XPSAQI
12593 ZUOSP(IXPS) = .TRUE.
12597 *>>>get x-values of valence partons
12599 IF (XVTHR.GT.0.05D0) THEN
12600 XVHI = ONE-XXSEA-XDTHR
12601 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12604 XPVQI = DT_DBETAR(OHALF,UNOPRV)
12605 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12609 XPVDI = ONE-XPVQI-XXSEA
12610 * reject according to x**1.5
12611 XDTMP = XPVDI**1.5D0
12612 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12613 * accept these valence partons
12619 ZUOVP(IXPV) = .TRUE.
12624 * (3) select parton x-values of interacting target nucleons
12625 *-----------------------------------------------------------------------
12631 * get interacting target nucleon as sampled by Glauber
12632 IF (JTSH(ITT).NE.0) THEN
12638 * JITT is the actual number of sea-pairs sampled for this nucleon
12639 JITT = MIN(JTSH(ITT)-1,NSMAX)
12642 IF (JITT.GT.0) THEN
12643 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12645 IF (XSTHR.GE.XSMAX) THEN
12650 *>>>get x-values of sea-quark pairs
12654 * accumulator for sea x-values
12657 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12658 IF (NSCOUN.GT.NSEA)THEN
12659 * decrease the number of interactions after NSEA trials
12665 IF (ITSQ(IXTS+1).LE.2) THEN
12666 **sr 8.4.98 (1/sqrt(x))
12667 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12668 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12669 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12672 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12673 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12675 **sr 8.4.98 (1/sqrt(x))
12676 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12677 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12678 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12683 IF (ITSAQ(IXTS+1).GE.-2) THEN
12684 **sr 8.4.98 (1/sqrt(x))
12685 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12686 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12687 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12690 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12691 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12693 **sr 8.4.98 (1/sqrt(x))
12694 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12695 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12696 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12700 XXSEA = XXSEA+XTSQI+XTSAQI
12701 * check for maximum allowed sea x-value
12702 IF (XXSEA.GE.XXSEAM) THEN
12706 * accept this sea-quark pair
12709 XTSAQ(IXTS) = XTSAQI
12711 ZUOST(IXTS) = .TRUE.
12715 *>>>get x-values of valence partons
12717 IF (XVTHR.GT.0.05D0) THEN
12718 XVHI = ONE-XXSEA-XDTHR
12719 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12722 XTVQI = DT_DBETAR(OHALF,UNON)
12723 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12727 XTVDI = ONE-XTVQI-XXSEA
12728 * reject according to x**1.5
12729 XDTMP = XTVDI**1.5D0
12730 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12731 * accept these valence partons
12737 ZUOVT(IXTV) = .TRUE.
12742 * (4) get valence-valence chains
12743 *-----------------------------------------------------------------------
12748 IPVAL = ITOVP(INTER1(I))
12749 ITVAL = ITOVT(INTER2(I))
12750 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12752 ZUOVP(IPVAL) = .FALSE.
12753 ZUOVT(ITVAL) = .FALSE.
12756 INTVV1(NVV) = IPVAL
12757 INTVV2(NVV) = ITVAL
12761 * (5) get sea-valence chains
12762 *-----------------------------------------------------------------------
12769 IPVAL = ITOVP(INTER1(I))
12770 ITVAL = ITOVT(INTER2(I))
12772 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12773 & ZUOVT(ITVAL)) THEN
12775 ZUOVT(ITVAL) = .FALSE.
12777 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12778 * sample sea-diquark pair
12779 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12780 IF (IREJ1.EQ.0) GOTO 260
12785 INTSV2(NSV) = ITVAL
12787 *>>>correct chain kinematics according to minimum chain masses
12788 * the actual chain masses
12789 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12790 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12791 * get lower mass cuts
12792 IF (IPSQ(J).EQ.3) THEN
12797 * q being u/d-quark
12802 * chain mass above minimum - resampling of sea-q x-value
12803 IF (AMSVQ1.GT.AMCHK1) THEN
12804 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
12805 **sr 8.4.98 (1/sqrt(x))
12806 C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
12807 C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
12808 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12810 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12812 * chain mass below minimum - reset sea-q x-value and correct
12813 * diquark-x of the same nucleon
12814 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12815 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
12816 DXPSQ = XPSQW-XPSQ(J)
12817 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12818 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12823 * chain mass below minimum - reset sea-aq x-value and correct
12824 * diquark-x of the same nucleon
12825 IF (AMSVQ2.LT.AMCHK2) THEN
12826 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12827 DXPSQ = XPSQW-XPSAQ(J)
12828 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12829 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12833 *>>>end of chain mass correction
12842 * (6) get valence-sea chains
12843 *-----------------------------------------------------------------------
12849 IPVAL = ITOVP(INTER1(I))
12850 ITVAL = ITOVT(INTER2(I))
12852 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12853 & (IFROST(J).EQ.INTER2(I))) THEN
12855 ZUOVP(IPVAL) = .FALSE.
12857 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12858 * sample sea-diquark pair
12859 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12860 IF (IREJ1.EQ.0) GOTO 290
12864 INTVS1(NVS) = IPVAL
12867 *>>>correct chain kinematics according to minimum chain masses
12868 * the actual chain masses
12869 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12870 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12871 * get lower mass cuts
12872 IF (ITSQ(J).EQ.3) THEN
12877 * q being u/d-quark
12882 * chain mass below minimum - reset sea-aq x-value and correct
12883 * diquark-x of the same nucleon
12884 IF (AMVSQ1.LT.AMCHK1) THEN
12885 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12886 DXTSQ = XTSQW-XTSAQ(J)
12887 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12888 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12893 * chain mass above minimum - resampling of sea-q x-value
12894 IF (AMVSQ2.GT.AMCHK2) THEN
12895 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
12896 **sr 8.4.98 (1/sqrt(x))
12897 C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
12898 C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
12899 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12901 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12903 * chain mass below minimum - reset sea-q x-value and correct
12904 * diquark-x of the same nucleon
12905 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12906 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
12907 DXTSQ = XTSQW-XTSQ(J)
12908 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12909 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12913 *>>>end of chain mass correction
12922 * (7) get sea-sea chains
12923 *-----------------------------------------------------------------------
12930 IPVAL = ITOVP(INTER1(I))
12931 ITVAL = ITOVT(INTER2(I))
12932 * loop over target partons not yet matched
12934 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12935 * loop over projectile partons not yet matched
12937 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12938 ZUOSP(JJ) = .FALSE.
12946 *---->chain recombination option
12947 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
12948 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12950 * sea-sea chains may recombine with valence-valence chains
12951 * only if they have the same projectile or target nucleon
12953 IF (ISKPCH(8,IVV).NE.99) THEN
12954 IXVPR = INTVV1(IVV)
12955 IXVTA = INTVV2(IVV)
12956 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12957 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12958 * recombination possible, drop old v-v and s-s chains
12962 * (a) assign new s-v chains
12963 * ~~~~~~~~~~~~~~~~~~~~~~~~~
12965 & (DT_RNDM(VALFRA).GT.FRCDIQ))
12967 * sample sea-diquark pair
12968 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12970 IF (IREJ1.EQ.0) GOTO 4202
12975 INTSV2(NSV) = IXVTA
12976 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12977 * the actual chain masses
12978 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12980 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12982 * get lower mass cuts
12983 IF (IPSQ(JJ).EQ.3) THEN
12988 * q being u/d-quark
12993 * chain mass above minimum - resampling of sea-q x-value
12994 IF (AMSVQ1.GT.AMCHK1) THEN
12996 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12997 **sr 8.4.98 (1/sqrt(x))
12999 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13000 C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
13001 C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
13004 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13006 * chain mass below minimum - reset sea-q x-value and correct
13007 * diquark-x of the same nucleon
13008 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13010 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13011 DXPSQ = XPSQW-XPSQ(JJ)
13012 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13015 & XPVD(IPVAL)-DXPSQ
13020 * chain mass below minimum - reset sea-aq x-value and correct
13021 * diquark-x of the same nucleon
13022 IF (AMSVQ2.LT.AMCHK2) THEN
13024 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
13025 DXPSQ = XPSQW-XPSAQ(JJ)
13026 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13029 & XPVD(IPVAL)-DXPSQ
13033 *>>>>>>>>>>>end of chain mass correction
13036 * (b) assign new v-s chains
13037 * ~~~~~~~~~~~~~~~~~~~~~~~~~
13039 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
13041 * sample sea-diquark pair
13042 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13044 IF (IREJ1.EQ.0) GOTO 4203
13048 INTVS1(NVS) = IXVPR
13050 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13051 * the actual chain masses
13052 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13053 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13054 * get lower mass cuts
13055 IF (ITSQ(J).EQ.3) THEN
13060 * q being u/d-quark
13065 * chain mass below minimum - reset sea-aq x-value and correct
13066 * diquark-x of the same nucleon
13067 IF (AMVSQ1.LT.AMCHK1) THEN
13069 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
13070 DXTSQ = XTSQW-XTSAQ(J)
13071 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13074 & XTVD(ITVAL)-DXTSQ
13078 IF (AMVSQ2.GT.AMCHK2) THEN
13080 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13081 **sr 8.4.98 (1/sqrt(x))
13083 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13084 C & DT_SAMSQX(XTSQTH,XTSQ(J))
13085 C & DT_SAMPEX(XTSQTH,XTSQ(J))
13088 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13090 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13092 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13093 DXTSQ = XTSQW-XTSQ(J)
13094 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13097 & XTVD(ITVAL)-DXTSQ
13101 *>>>>>>>>>end of chain mass correction
13103 * jump out of s-s chain loop
13109 *---->end of chain recombination option
13111 * sample sea-diquark pair (projectile)
13112 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13113 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13114 IF (IREJ1.EQ.0) THEN
13119 * sample sea-diquark pair (target)
13120 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13121 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13122 IF (IREJ1.EQ.0) THEN
13127 *>>>>>correct chain kinematics according to minimum chain masses
13128 * the actual chain masses
13129 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13130 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13131 * check for lower mass cuts
13132 IF ((SSMA1Q.LT.SSMIMQ).OR.
13133 & (SSMA2Q.LT.SSMIMQ)) THEN
13134 IPVAL = ITOVP(INTER1(I))
13135 ITVAL = ITOVT(INTER2(I))
13136 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13137 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13138 * maximum allowed x values for sea quarks
13139 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13141 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13143 * resampling of x values not possible - skip sea-sea chains
13144 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13145 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13146 * resampling of x for projectile sea quark pair
13150 IF (XSSTHR.GT.0.05D0) THEN
13151 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13153 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13157 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13158 IF ((XPSQI.LT.XSSTHR).OR.
13159 & (XPSQI.GT.XSPMAX)) GOTO 320
13161 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13162 IF ((XPSAQI.LT.XSSTHR).OR.
13163 & (XPSAQI.GT.XSPMAX)) GOTO 330
13165 * final test of remaining x for projectile diquark
13166 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13167 & +XPSQ(JJ)+XPSAQ(JJ)
13168 IF (XPVDCO.LE.XDTHR) THEN
13170 C IF (ICOUS.LT.5) GOTO 310
13171 IF (ICOUS.LT.0.5D0) GOTO 310
13174 * resampling of x for target sea quark pair
13178 IF (XSSTHR.GT.0.05D0) THEN
13179 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13181 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13185 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13186 IF ((XTSQI.LT.XSSTHR).OR.
13187 & (XTSQI.GT.XSTMAX)) GOTO 360
13189 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13190 IF ((XTSAQI.LT.XSSTHR).OR.
13191 & (XTSAQI.GT.XSTMAX)) GOTO 370
13193 * final test of remaining x for target diquark
13194 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13195 & +XTSQ(J)+XTSAQ(J)
13196 IF (XTVDCO.LT.XDTHR) THEN
13197 IF (ICOUS.LT.5) GOTO 350
13200 XPVD(IPVAL) = XPVDCO
13201 XTVD(ITVAL) = XTVDCO
13206 *>>>>>end of chain mass correction
13209 * come here to discard s-s interaction
13210 * resampling of x values not allowed or unsuccessful
13217 * consider next s-s interaction
13227 * correct x-values of valence quarks for non-matching sea quarks
13230 IPVAL = ITOVP(IFROSP(I))
13231 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13239 ITVAL = ITOVT(IFROST(I))
13240 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13247 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13250 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13256 *===samsdq=============================================================*
13258 CDECK ID>, DT_SAMSDQ
13259 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13261 ************************************************************************
13262 * SAMpling of Sea-DiQuarks *
13263 * ECM cm-energy of the nucleon-nucleon system *
13264 * IDX1,2 indices of x-values of the participating *
13265 * partons (IDX2 is always the sea-q-pair to be *
13266 * changed to sea-qq-pair) *
13267 * MODE = 1 valence-q - sea-diq *
13268 * = 2 sea-diq - valence-q *
13269 * = 3 sea-q - sea-diq *
13270 * = 4 sea-diq - sea-q *
13271 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13272 * This version dated 17.10.95 is written by S. Roesler *
13273 ************************************************************************
13275 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13278 PARAMETER (ZERO=0.0D0)
13280 * threshold values for x-sampling (DTUNUC 1.x)
13281 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13283 * various options for treatment of partons (DTUNUC 1.x)
13284 * (chain recombination, Cronin,..)
13285 LOGICAL LCO2CR,LINTPT
13286 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13289 PARAMETER ( MAXNCL = 260,
13292 & MAXSQU = 20*MAXVQU,
13293 & MAXINT = MAXVQU+MAXSQU)
13294 * x-values of partons (DTUNUC 1.x)
13295 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13296 & XTVQ(MAXVQU),XTVD(MAXVQU),
13297 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13298 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13299 * flavors of partons (DTUNUC 1.x)
13300 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13301 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13302 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13303 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13304 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13305 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13306 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13307 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13308 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13309 & IXPV,IXPS,IXTV,IXTS,
13310 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13311 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13312 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13313 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13314 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13315 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13316 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13317 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13318 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13319 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13320 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13321 * auxiliary common for chain system storage (DTUNUC 1.x)
13322 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13325 * threshold-x for valence diquarks
13328 GOTO (1,2,3,4) MODE
13330 *---------------------------------------------------------------------
13331 * proj. valence partons - targ. sea partons
13332 * get x-values and flavors for target sea-diquark pair
13338 * index of corr. val-diquark-x in target nucleon
13339 IDXVT = ITOVT(IFROST(IDXST))
13340 * available x above diquark thresholds for valence- and sea-diquarks
13341 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13343 IF (XXD.GE.ZERO) THEN
13344 * x-values for the three diquarks of the target nucleon
13348 SR123 = RR1+RR2+RR3
13349 XXTV = XDTHR+RR1*XXD/SR123
13350 XXTSQ = XDTHR+RR2*XXD/SR123
13351 XXTSAQ = XDTHR+RR3*XXD/SR123
13354 XXTSQ = XTSQ(IDXST)
13355 XXTSAQ = XTSAQ(IDXST)
13357 * flavor of the second quarks in the sea-diquark pair
13358 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13359 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13360 * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13361 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13362 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13363 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13365 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13368 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13369 * at least one strange quark
13370 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13373 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13377 * accept the new sea-diquark
13379 XTSQ(IDXST) = XXTSQ
13380 XTSAQ(IDXST) = XXTSAQ
13382 INTVD1(NVD) = IDXVP
13383 INTVD2(NVD) = IDXST
13387 *---------------------------------------------------------------------
13388 * proj. sea partons - targ. valence partons
13389 * get x-values and flavors for projectile sea-diquark pair
13395 * index of corr. val-diquark-x in projectile nucleon
13396 IDXVP = ITOVP(IFROSP(IDXSP))
13397 * available x above diquark thresholds for valence- and sea-diquarks
13398 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13400 IF (XXD.GE.ZERO) THEN
13401 * x-values for the three diquarks of the projectile nucleon
13405 SR123 = RR1+RR2+RR3
13406 XXPV = XDTHR+RR1*XXD/SR123
13407 XXPSQ = XDTHR+RR2*XXD/SR123
13408 XXPSAQ = XDTHR+RR3*XXD/SR123
13411 XXPSQ = XPSQ(IDXSP)
13412 XXPSAQ = XPSAQ(IDXSP)
13414 * flavor of the second quarks in the sea-diquark pair
13415 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13416 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13417 * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13418 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13419 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13420 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13422 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13425 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13426 * at least one strange quark
13427 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13430 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13434 * accept the new sea-diquark
13436 XPSQ(IDXSP) = XXPSQ
13437 XPSAQ(IDXSP) = XXPSAQ
13439 INTDV1(NDV) = IDXSP
13440 INTDV2(NDV) = IDXVT
13444 *---------------------------------------------------------------------
13445 * proj. sea partons - targ. sea partons
13446 * get x-values and flavors for target sea-diquark pair
13452 * index of corr. val-diquark-x in target nucleon
13453 IDXVT = ITOVT(IFROST(IDXST))
13454 * available x above diquark thresholds for valence- and sea-diquarks
13455 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13457 IF (XXD.GE.ZERO) THEN
13458 * x-values for the three diquarks of the target nucleon
13462 SR123 = RR1+RR2+RR3
13463 XXTV = XDTHR+RR1*XXD/SR123
13464 XXTSQ = XDTHR+RR2*XXD/SR123
13465 XXTSAQ = XDTHR+RR3*XXD/SR123
13468 XXTSQ = XTSQ(IDXST)
13469 XXTSAQ = XTSAQ(IDXST)
13471 * flavor of the second quarks in the sea-diquark pair
13472 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13473 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13474 * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13475 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
13476 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13477 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13479 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13482 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13483 * at least one strange quark
13484 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13487 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13491 * accept the new sea-diquark
13493 XTSQ(IDXST) = XXTSQ
13494 XTSAQ(IDXST) = XXTSAQ
13496 INTSD1(NSD) = IDXSP
13497 INTSD2(NSD) = IDXST
13501 *---------------------------------------------------------------------
13502 * proj. sea partons - targ. sea partons
13503 * get x-values and flavors for projectile sea-diquark pair
13509 * index of corr. val-diquark-x in projectile nucleon
13510 IDXVP = ITOVP(IFROSP(IDXSP))
13511 * available x above diquark thresholds for valence- and sea-diquarks
13512 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13514 IF (XXD.GE.ZERO) THEN
13515 * x-values for the three diquarks of the projectile nucleon
13519 SR123 = RR1+RR2+RR3
13520 XXPV = XDTHR+RR1*XXD/SR123
13521 XXPSQ = XDTHR+RR2*XXD/SR123
13522 XXPSAQ = XDTHR+RR3*XXD/SR123
13525 XXPSQ = XPSQ(IDXSP)
13526 XXPSAQ = XPSAQ(IDXSP)
13528 * flavor of the second quarks in the sea-diquark pair
13529 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13530 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13531 * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13532 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
13533 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
13534 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13536 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13539 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13540 * at least one strange quark
13541 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13544 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13548 * accept the new sea-diquark
13550 XPSQ(IDXSP) = XXPSQ
13551 XPSAQ(IDXSP) = XXPSAQ
13553 INTDS1(NDS) = IDXSP
13554 INTDS2(NDS) = IDXST
13559 *===difevt=============================================================*
13561 CDECK ID>, DT_DIFEVT
13562 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13563 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13565 ************************************************************************
13566 * Interface to treatment of diffractive interactions. *
13567 * (input) IFP1/2 PDG-indizes of projectile partons *
13568 * (baryon: IFP2 - adiquark) *
13569 * PP(4) projectile 4-momentum *
13570 * IFT1/2 PDG-indizes of target partons *
13571 * (baryon: IFT1 - adiquark) *
13572 * PT(4) target 4-momentum *
13573 * (output) JDIFF = 0 no diffraction *
13574 * = 1/-1 LMSD/LMDD *
13575 * = 2/-2 HMSD/HMDD *
13576 * NCSY counter for two-chain systems *
13577 * dumped to DTEVT1 *
13578 * This version dated 14.02.95 is written by S. Roesler *
13579 ************************************************************************
13581 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13584 PARAMETER ( LINP = 5 ,
13588 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13593 PARAMETER (NMXHKK=200000)
13595 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13596 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13597 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13598 * extended event history
13599 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13600 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13602 * flags for diffractive interactions (DTUNUC 1.x)
13603 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13605 DIMENSION PP(4),PT(4)
13608 DATA LFIRST /.TRUE./
13615 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13616 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13617 * identities of projectile hadron / target nucleon
13618 KPROJ = IDT_ICIHAD(IDHKK(MOP))
13619 KTARG = IDT_ICIHAD(IDHKK(MOT))
13621 * single diffractive xsections
13622 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13623 * double diffractive xsections
13624 **!! no double diff yet
13625 C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13629 * total inelastic xsection
13630 C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13632 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13633 SIGIN = MAX(SIGTO-SIGEL,ZERO)
13635 * fraction of diffractive processes
13636 FRADIF = (SDTOT+DDTOT)/SIGIN
13639 WRITE(LOUT,1000) XM,SDTOT,SIGIN
13640 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13641 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13646 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13647 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13648 * diffractive interaction requested by x-section or by user
13649 FRASD = SDTOT/(SDTOT+DDTOT)
13650 FRASDH = SDHM/SDTOT
13651 **sr needs to be specified!!
13652 C FRADDH = DDHM/DDTOT
13655 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13656 * single diffraction
13658 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13661 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13662 & ISINGD.NE.3) THEN
13669 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13670 & ISINGD.NE.3) THEN
13676 * double diffraction
13678 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13686 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13687 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13688 IF (IREJ1.EQ.0) THEN
13690 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13704 *===difkin=============================================================*
13706 CDECK ID>, DT_DIFFKI
13707 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13708 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13710 ************************************************************************
13711 * Kinematics of diffractive nucleon-nucleon interaction. *
13712 * IFP1/2 PDG-indizes of projectile partons *
13713 * (baryon: IFP2 - adiquark) *
13714 * PP(4) projectile 4-momentum *
13715 * IFT1/2 PDG-indizes of target partons *
13716 * (baryon: IFT1 - adiquark) *
13717 * PT(4) target 4-momentum *
13718 * KP = 0 projectile quasi-elastically scattered *
13719 * = 1 excited to low-mass diff. state *
13720 * = 2 excited to high-mass diff. state *
13721 * KT = 0 target quasi-elastically scattered *
13722 * = 1 excited to low-mass diff. state *
13723 * = 2 excited to high-mass diff. state *
13724 * This version dated 12.02.95 is written by S. Roesler *
13725 ************************************************************************
13727 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13730 PARAMETER ( LINP = 5 ,
13734 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13738 * particle properties (BAMJET index convention)
13740 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13741 & IICH(210),IIBAR(210),K1(210),K2(210)
13742 * flags for input different options
13743 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13744 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13745 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13746 * rejection counter
13747 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13748 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13749 & IREXCI(3),IRDIFF(2),IRINC
13750 * kinematics of diffractive interactions (DTUNUC 1.x)
13751 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13753 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13754 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13756 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13757 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13759 DATA LSTART /.TRUE./
13763 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
13769 * initialize common /DTDIKI/
13771 * store momenta of initial incoming particles for emc-check
13773 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13774 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13777 * masses of initial particles
13778 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13779 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13780 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13783 * check quark-input (used to adjust coherence cond. for M-selection)
13785 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13787 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13789 * parameter for Lorentz-transformation into nucleon-nucleon cms
13791 PITOT(K) = PP(K)+PT(K)
13793 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13794 IF (XMTOT2.LE.ZERO) THEN
13795 WRITE(LOUT,1000) XMTOT2
13796 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
13797 & 'XMTOT2 = ',E12.3)
13800 XMTOT = SQRT(XMTOT2)
13802 BGTOT(K) = PITOT(K)/XMTOT
13804 * transformation of nucleons into cms
13805 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13806 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13807 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13808 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13811 C SID = SQRT((ONE-COD)*(ONE+COD))
13812 PPT = SQRT(PP1(1)**2+PP1(2)**2)
13816 IF(PPTOT*SID.GT.TINY10) THEN
13817 COF = PP1(1)/(SID*PPTOT)
13818 SIF = PP1(2)/(SID*PPTOT)
13819 ANORF = SQRT(COF*COF+SIF*SIF)
13823 * check consistency
13825 DEV1(K) = ABS(PP1(K)+PT1(K))
13827 DEV1(4) = ABS(DEV1(4)-XMTOT)
13828 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13829 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
13830 WRITE(LOUT,1001) DEV1
13831 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
13836 * select x-fractions in high-mass diff. interactions
13837 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13839 * select diffractive masses
13842 XMPF = DT_XMLMD(XMTOT)
13843 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13844 IF (IREJ1.GT.0) GOTO 9999
13845 ELSEIF (KP.EQ.2) THEN
13846 XMPF = DT_XMHMD(XMTOT,IBP,1)
13852 XMTF = DT_XMLMD(XMTOT)
13853 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13854 IF (IREJ1.GT.0) GOTO 9999
13855 ELSEIF (KT.EQ.2) THEN
13856 XMTF = DT_XMHMD(XMTOT,IBT,2)
13861 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13864 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13865 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13867 * select momentum transfer (all t-values used here are <0)
13868 * minimum absolute value to produce diffractive masses
13869 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13870 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13871 IF (IREJ1.GT.0) GOTO 9999
13873 * longitudinal momentum of excited/elastically scattered projectile
13874 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13875 * total transverse momentum due to t-selection
13876 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13877 IF (PPBLT2.LT.ZERO) THEN
13878 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13879 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
13880 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13883 CALL DT_DSFECF(SINPHI,COSPHI)
13884 PPBLT = SQRT(PPBLT2)
13885 PPBLOB(1) = COSPHI*PPBLT
13886 PPBLOB(2) = SINPHI*PPBLT
13888 * rotate excited/elastically scattered projectile into n-n cms.
13889 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13895 * 4-momentum of excited/elastically scattered target and of exchanged
13898 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13899 PPOM1(K) = PP1(K)-PPBLOB(K)
13901 PTBLOB(4) = XMTOT-PPBLOB(4)
13903 * Lorentz-transformation back into system of initial diff. collision
13904 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13905 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13906 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13907 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13908 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13909 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13910 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13911 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13912 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13914 * store 4-momentum of elastically scattered particle (in single diff.
13920 ELSEIF (KT.EQ.0) THEN
13926 * check consistency of kinematical treatment so far
13928 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13929 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13930 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13931 IF (IREJ1.NE.0) GOTO 9999
13934 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13935 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13937 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13938 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13939 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13940 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
13941 WRITE(LOUT,1003) DEV1,DEV2
13942 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
13947 * kinematical treatment for low-mass diffraction
13948 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13949 IF (IREJ1.NE.0) GOTO 9999
13951 * dump diffractive chains into DTEVT1
13952 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13953 IF (IREJ1.NE.0) GOTO 9999
13958 IRDIFF(1) = IRDIFF(1)+1
13963 *===xmhmd==============================================================*
13965 CDECK ID>, DT_XMHMD
13966 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13968 ************************************************************************
13969 * Diffractive mass in high mass single/double diffractive events. *
13970 * This version dated 11.02.95 is written by S. Roesler *
13971 ************************************************************************
13973 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13976 PARAMETER ( LINP = 5 ,
13980 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13982 * kinematics of diffractive interactions (DTUNUC 1.x)
13983 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13985 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13986 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13988 C DATA XCOLOW /0.05D0/
13989 DATA XCOLOW /0.15D0/
13993 IF (MODE.EQ.2) XH = XTH(2)
13995 * minimum Pomeron-x for high-mass diffraction
13996 * (adjusted to get a smooth transition between HM and LM component)
13998 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13999 IF (ECM.LE.300.0D0) THEN
14000 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14001 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14003 * maximum Pomeron-x for high-mass diffraction
14004 * (coherence condition, adjusted to fit to experimental data)
14006 * baryon-diffraction
14007 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14009 * meson-diffraction
14010 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14013 IF (XDIMIN.GE.XDIMAX) THEN
14014 XDIMIN = OHALF*XDIMAX
14020 IF (KLOOP.GT.20) RETURN
14021 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
14022 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14023 * corr. diffr. mass
14024 DT_XMHMD = ECM*SQRT(XDIFF)
14025 IF (DT_XMHMD.LT.2.5D0) GOTO 1
14030 *===xmlmd==============================================================*
14032 CDECK ID>, DT_XMLMD
14033 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14035 ************************************************************************
14036 * Diffractive mass in high mass single/double diffractive events. *
14037 * This version dated 11.02.95 is written by S. Roesler *
14038 ************************************************************************
14040 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14043 PARAMETER ( LINP = 5 ,
14047 * minimum Pomeron-x for low-mass diffraction
14050 * maximum Pomeron-x for low-mass diffraction
14051 * (adjusted to get a smooth transition between HM and LM component)
14054 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14055 R = DT_RNDM(AMO)*SAM
14056 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14057 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14059 * selection of diffractive mass
14060 * (adjusted to get a smooth transition between HM and LM component)
14062 IF (ECM.LE.50.0D0) THEN
14063 DT_XMLMD = AMO*(AMU/AMO)**R
14066 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14067 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14073 *===tdiff==============================================================*
14075 CDECK ID>, DT_TDIFF
14076 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14078 ************************************************************************
14079 * t-selection for single/double diffractive interactions. *
14081 * TMIN minimum momentum transfer to produce diff. masses *
14082 * XM1/XM2 diffractively produced masses *
14083 * (for single diffraction XM2 is obsolete) *
14084 * K1/K2= 0 not excited *
14085 * = 1 low-mass excitation *
14086 * = 2 high-mass excitation *
14087 * This version dated 11.02.95 is written by S. Roesler *
14088 ************************************************************************
14090 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14093 PARAMETER ( LINP = 5 ,
14097 PARAMETER (ZERO=0.0D0)
14099 PARAMETER ( BTP0 = 3.7D0,
14100 & ALPHAP = 0.24D0 )
14113 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14114 * slope for single diffraction
14115 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14117 * slope for double diffraction
14118 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14123 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14125 T = -LOG(1.0D0-Y)/SLOPE
14126 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14132 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14133 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14134 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14135 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14140 *===xvalhm=============================================================*
14142 CDECK ID>, DT_XVALHM
14143 SUBROUTINE DT_XVALHM(KP,KT)
14145 ************************************************************************
14146 * Sampling of parton x-values in high-mass diffractive interactions. *
14147 * This version dated 12.02.95 is written by S. Roesler *
14148 ************************************************************************
14150 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14153 PARAMETER ( LINP = 5 ,
14157 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14159 * kinematics of diffractive interactions (DTUNUC 1.x)
14160 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14162 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14163 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14164 * various options for treatment of partons (DTUNUC 1.x)
14165 * (chain recombination, Cronin,..)
14166 LOGICAL LCO2CR,LINTPT
14167 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14170 DATA UNON,XVQTHR /2.0D0,0.8D0/
14173 * x-fractions of projectile valence partons
14175 XPH(1) = DT_DBETAR(OHALF,UNON)
14176 IF (XPH(1).GE.XVQTHR) GOTO 1
14177 XPH(2) = ONE-XPH(1)
14178 * x-fractions of Pomeron q-aq-pair
14181 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14182 XPPO(2) = ONE-XPPO(1)
14183 * flavors of Pomeron q-aq-pair
14184 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14187 IF (DT_RNDM(UNON).GT.OHALF) THEN
14194 * x-fractions of projectile target partons
14196 XTH(1) = DT_DBETAR(OHALF,UNON)
14197 IF (XTH(1).GE.XVQTHR) GOTO 2
14198 XTH(2) = ONE-XTH(1)
14199 * x-fractions of Pomeron q-aq-pair
14202 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14203 XTPO(2) = ONE-XTPO(1)
14204 * flavors of Pomeron q-aq-pair
14205 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14208 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14217 *===lm2res=============================================================*
14219 CDECK ID>, DT_LM2RES
14220 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14222 ************************************************************************
14223 * Check low-mass diffractive excitation for resonance mass. *
14224 * (input) IF1/2 PDG-indizes of valence partons *
14225 * (in/out) XM diffractive mass requested/corrected *
14226 * (output) IDR/IDXR id./BAMJET-index of resonance *
14227 * This version dated 12.02.95 is written by S. Roesler *
14228 ************************************************************************
14230 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14233 PARAMETER ( LINP = 5 ,
14237 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14239 * kinematics of diffractive interactions (DTUNUC 1.x)
14240 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14242 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14243 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14250 * BAMJET indices of partons
14251 IF1A = IDT_IPDG2B(IF1,1,2)
14252 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14253 IF2A = IDT_IPDG2B(IF2,1,2)
14254 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14256 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14258 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14260 * check for resonance mass
14261 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14262 IF (IREJ1.NE.0) GOTO 9999
14272 *===lmkine=============================================================*
14274 CDECK ID>, DT_LMKINE
14275 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14277 ************************************************************************
14278 * Kinematical treatment of low-mass excitations. *
14279 * This version dated 12.02.95 is written by S. Roesler *
14280 ************************************************************************
14282 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14285 PARAMETER ( LINP = 5 ,
14289 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14291 * flags for input different options
14292 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14293 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14294 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14295 * kinematics of diffractive interactions (DTUNUC 1.x)
14296 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14298 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14299 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14301 DIMENSION P1(4),P2(4)
14306 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14308 FAC1 = OHALF*(POE+ONE)
14309 FAC2 = -OHALF*(POE-ONE)
14311 PPLM1(K) = FAC1*PPF(K)
14312 PPLM2(K) = FAC2*PPF(K)
14314 PPLM1(4) = FAC1*PABS
14315 PPLM2(4) = -FAC2*PABS
14316 IF (IMSHL.EQ.1) THEN
14321 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14322 IF (IREJ1.NE.0) GOTO 9999
14331 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14333 FAC1 = OHALF*(POE+ONE)
14334 FAC2 = -OHALF*(POE-ONE)
14336 PTLM2(K) = FAC1*PTF(K)
14337 PTLM1(K) = FAC2*PTF(K)
14339 PTLM2(4) = FAC1*PABS
14340 PTLM1(4) = -FAC2*PABS
14341 IF (IMSHL.EQ.1) THEN
14346 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14347 IF (IREJ1.NE.0) GOTO 9999
14358 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14363 *===difini=============================================================*
14365 CDECK ID>, DT_DIFINI
14366 SUBROUTINE DT_DIFINI
14368 ************************************************************************
14369 * Initialization of common /DTDIKI/ *
14370 * This version dated 12.02.95 is written by S. Roesler *
14371 ************************************************************************
14373 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14376 PARAMETER ( LINP = 5 ,
14380 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14382 * kinematics of diffractive interactions (DTUNUC 1.x)
14383 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14385 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14386 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14414 *===difput=============================================================*
14416 CDECK ID>, DT_DIFPUT
14417 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14420 ************************************************************************
14421 * Dump diffractive chains into DTEVT1 *
14422 * This version dated 12.02.95 is written by S. Roesler *
14423 ************************************************************************
14425 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14428 PARAMETER ( LINP = 5 ,
14432 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14436 * kinematics of diffractive interactions (DTUNUC 1.x)
14437 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14439 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14440 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14443 PARAMETER (NMXHKK=200000)
14445 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14446 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14447 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14448 * extended event history
14449 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14450 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14452 * rejection counter
14453 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14454 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14455 & IREXCI(3),IRDIFF(2),IRINC
14457 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14458 & P1(4),P2(4),P3(4),P4(4)
14464 PCH(K) = PPLM1(K)+PPLM2(K)
14468 IF (DT_RNDM(PT).GT.OHALF) THEN
14472 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14474 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14476 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14478 ELSEIF (KP.EQ.2) THEN
14480 PP1(K) = XPH(1)*PP(K)
14481 PP2(K) = XPH(2)*PP(K)
14482 PT1(K) = -XPPO(1)*PPOM(K)
14483 PT2(K) = -XPPO(2)*PPOM(K)
14485 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14489 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14490 IF (IREJ1.NE.0) GOTO 9999
14491 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14492 IF (IREJ1.NE.0) GOTO 9999
14499 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14501 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14503 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14505 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14508 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14509 IF (IREJ1.NE.0) GOTO 9999
14510 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14511 IF (IREJ1.NE.0) GOTO 9999
14518 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14520 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14522 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14524 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14529 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14535 PCH(K) = PTLM1(K)+PTLM2(K)
14539 IF (DT_RNDM(PT).GT.OHALF) THEN
14543 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14545 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14547 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14549 ELSEIF (KT.EQ.2) THEN
14551 PP1(K) = XTPO(1)*PPOM(K)
14552 PP2(K) = XTPO(2)*PPOM(K)
14553 PT1(K) = XTH(2)*PT(K)
14554 PT2(K) = XTH(1)*PT(K)
14556 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14560 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14561 IF (IREJ1.NE.0) GOTO 9999
14562 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14563 IF (IREJ1.NE.0) GOTO 9999
14570 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14572 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14574 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14576 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14579 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14580 IF (IREJ1.NE.0) GOTO 9999
14581 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14582 IF (IREJ1.NE.0) GOTO 9999
14589 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14591 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14593 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14595 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14600 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14607 IRDIFF(2) = IRDIFF(2)+1
14612 *===evtfrg=============================================================*
14614 CDECK ID>, DT_EVTFRG
14615 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14617 ************************************************************************
14618 * Hadronization of chains in DTEVT1. *
14621 * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
14622 * = 2 hadronization of DTUNUC-chains (id=88xxx) *
14623 * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
14624 * hadronized with one PYEXEC call *
14625 * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14626 * with one PYEXEC call *
14628 * NPYMEM number of entries in JETSET-common after hadronization *
14629 * IREJ rejection flag *
14631 * This version dated 17.09.00 is written by S. Roesler *
14632 ************************************************************************
14634 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14637 PARAMETER ( LINP = 5 ,
14641 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14642 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14646 PARAMETER (MXJOIN=200)
14650 PARAMETER (NMXHKK=200000)
14652 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14653 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14654 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14655 * extended event history
14656 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14657 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14659 * flags for input different options
14660 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14661 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14662 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14664 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14665 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14667 * flags for diffractive interactions (DTUNUC 1.x)
14668 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14669 * nucleon-nucleon event-generator
14672 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14674 C model switches and parameters
14676 INTEGER ISWMDL,IPAMDL
14677 DOUBLE PRECISION PARMDL
14678 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14681 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14683 PARAMETER (MAXLND=4000)
14684 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14688 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14692 IF (MODE.NE.1) ISTSTG = 8
14701 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14702 DO 10 I=NPOINT(3),NEND
14703 * sr 14.02.00: seems to be not necessary anymore, commented
14704 C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14705 C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14707 * pick up chains from dtevt1
14708 IDCHK = IDHKK(I)/10000
14709 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14710 IF (IDCHK.EQ.7) THEN
14711 IPJE = IDHKK(I)-IDCHK*10000
14712 IF (IPJE.NE.IFRG) THEN
14714 IF (IFRG.GT.NFRG) GOTO 16
14719 IF (IFRG.GT.NFRG) THEN
14724 * statistics counter
14725 c IF (IDCH(I).LE.8)
14726 c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14727 c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14728 * special treatment for small chains already corrected to hadrons
14729 IF (IDRES(I).NE.0) THEN
14730 IF (IDRES(I).EQ.11) THEN
14733 ID = IDT_IPDGHA(IDXRES(I))
14736 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14737 & PHKK(4,I),INIEMC,IDUM,IDUM)
14741 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14742 P(IP,1) = PHKK(1,I)
14743 P(IP,2) = PHKK(2,I)
14744 P(IP,3) = PHKK(3,I)
14745 P(IP,4) = PHKK(4,I)
14746 P(IP,5) = PHKK(5,I)
14752 IHIST(2,I) = 10000*IPJE+IP
14753 IF (IHIST(1,I).LE.-100) THEN
14755 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14762 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14764 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14765 & PHKK(4,KK),INIEMC,IDUM,IDUM)
14766 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14770 IF (ID.EQ.0) ID = 21
14771 c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14772 c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14774 c AMRQ = PYMASS(ID)
14776 c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14777 c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14778 c & (ABS(IDIFF).EQ.0)) THEN
14779 cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14780 c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14781 c PHKK(4,KK) = PHKK(4,KK)+DELTA
14782 c PTOT1 = PTOT-DELTA
14783 c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14784 c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14785 c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14786 c PHKK(5,KK) = AMRQ
14789 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14790 P(IP,1) = PHKK(1,KK)
14791 P(IP,2) = PHKK(2,KK)
14792 P(IP,3) = PHKK(3,KK)
14793 P(IP,4) = PHKK(4,KK)
14794 P(IP,5) = PHKK(5,KK)
14800 IHIST(2,KK) = 10000*IPJE+IP
14801 IF (IHIST(1,KK).LE.-100) THEN
14803 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14807 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14812 * join the two-parton system
14814 CALL PYJOIN(IJ,IJOIN)
14825 * final state parton shower
14827 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14828 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14830 IF (ISJOIN(K1).EQ.0) GOTO 130
14832 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14834 IH1 = IHIST(2,I)/10000
14835 IF (IH1.NE.NPJE) GOTO 130
14836 IH1 = IHIST(2,I)-IH1*10000
14838 IF (ISJOIN(K2).EQ.0) GOTO 135
14840 IH2 = IHIST(2,II)/10000
14841 IF (IH2.NE.NPJE) GOTO 135
14842 IH2 = IHIST(2,II)-IH2*10000
14843 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14844 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14845 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14847 RQLUN = MIN(PT1,PT2)
14848 CALL PYSHOW(IH1,IH2,RQLUN)
14860 CALL DT_INITJS(MODE)
14865 IF (MSTU(24).NE.0) THEN
14866 WRITE(LOUT,*) ' JETSET-reject at event',
14867 & NEVHKK,MSTU(24),KMODE
14868 C CALL DT_EVTOUT(4)
14875 * number of entries in LUJETS
14887 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14889 * pick up mother resonance if possible and put it together with
14890 * their decay-products into the common
14892 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14893 KFMOR = K(IDXMOR,2)
14894 ISMOR = K(IDXMOR,1)
14899 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14900 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14903 MO = IHISMO(PYK(IDXMOR,15))
14909 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14912 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14914 IF (PYK(JDAUG,7).EQ.1) THEN
14921 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14929 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14935 * there was no mother resonance
14937 MO = IHISMO(PYK(II,15))
14944 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14952 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14959 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14960 C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14963 * global energy-momentum & flavor conservation check
14964 **sr 16.5. this check is skipped in case of phojet-treatment
14966 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14968 * update statistics-counter for diffraction
14969 c IF (IFLAGD.NE.0) THEN
14970 c ICDIFF(1) = ICDIFF(1)+1
14971 c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14972 c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14973 c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14974 c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14986 *===decay==============================================================*
14988 CDECK ID>, DT_DECAYS
14989 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14991 ************************************************************************
14992 * Resonance-decay. *
14993 * This subroutine replaces DDECAY/DECHKK. *
14994 * PIN(4) 4-momentum of resonance (input) *
14995 * IDXIN BAMJET-index of resonance (input) *
14996 * POUT(20,4) 4-momenta of decay-products (output) *
14997 * IDXOUT(20) BAMJET-indices of decay-products (output) *
14998 * NSEC number of secondaries (output) *
14999 * Adopted from the original version DECHKK. *
15000 * This version dated 09.01.95 is written by S. Roesler *
15001 ************************************************************************
15003 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15006 PARAMETER ( LINP = 5 ,
15010 PARAMETER (TINY17=1.0D-17)
15012 * HADRIN: decay channel information
15013 PARAMETER (IDMAX9=602)
15015 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15016 * particle properties (BAMJET index convention)
15018 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15019 & IICH(210),IIBAR(210),K1(210),K2(210)
15020 * flags for input different options
15021 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15022 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15023 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15025 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15026 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15027 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15029 * ISTAB = 1 strong and weak decays
15030 * = 2 strong decays only
15031 * = 3 strong decays, weak decays for charmed particles and tau
15037 * put initial resonance to stack
15039 IDXSTK(NSTK) = IDXIN
15041 PI(NSTK,I) = PIN(I)
15044 * store initial configuration for energy-momentum cons. check
15045 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15046 & PI(NSTK,4),1,IDUM,IDUM)
15049 * get particle from stack
15050 IDXI = IDXSTK(NSTK)
15051 * skip stable particles
15052 IF (ISTAB.EQ.1) THEN
15053 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15054 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
15055 ELSEIF (ISTAB.EQ.2) THEN
15056 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
15057 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15058 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15059 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15060 IF ( IDXI.EQ.109) GOTO 10
15061 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15062 ELSEIF (ISTAB.EQ.3) THEN
15063 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
15064 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15065 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15066 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15069 * calculate direction cosines and Lorentz-parameter of decaying part.
15070 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15071 PTOT = MAX(PTOT,TINY17)
15073 DCOS(I) = PI(NSTK,I)/PTOT
15075 GAM = PI(NSTK,4)/AAM(IDXI)
15076 BGAM = PTOT/AAM(IDXI)
15078 * get decay-channel
15082 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15084 * identities of secondaries
15085 IDX(1) = NZK(KCHAN,1)
15086 IDX(2) = NZK(KCHAN,2)
15087 IF (IDX(2).LT.1) GOTO 9999
15088 IDX(3) = NZK(KCHAN,3)
15090 * handle decay in rest system of decaying particle
15091 IF (IDX(3).EQ.0) THEN
15092 * two-particle decay
15094 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15095 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15096 & AAM(IDX(1)),AAM(IDX(2)))
15098 * three-particle decay
15100 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15101 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15102 & CODF(3),COFF(3),SIFF(3),
15103 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15107 * transform decay products back
15110 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15111 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15112 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15113 * add particle to stack
15114 IDXSTK(NSTK) = IDX(I)
15116 PI(NSTK,J) = DCOSF(J)*PFF(I)
15122 * stable particle, put to output-arrays
15125 POUT(NSEC,I) = PI(NSTK,I)
15127 IDXOUT(NSEC) = IDXSTK(NSTK)
15128 * store secondaries for energy-momentum conservation check
15130 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15131 & -POUT(NSEC,4),2,IDUM,IDUM)
15133 IF (NSTK.GT.0) GOTO 100
15135 * check energy-momentum conservation
15137 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15138 IF (IREJ1.NE.0) GOTO 9999
15148 *===decay1=============================================================*
15150 CDECK ID>, DT_DECAY1
15151 SUBROUTINE DT_DECAY1
15153 ************************************************************************
15154 * Decay of resonances stored in DTEVT1. *
15155 * This version dated 20.01.95 is written by S. Roesler *
15156 ************************************************************************
15158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15161 PARAMETER ( LINP = 5 ,
15167 PARAMETER (NMXHKK=200000)
15169 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15170 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15171 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15172 * extended event history
15173 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15174 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15177 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15180 C DO 1 I=NPOINT(5),NEND
15181 DO 1 I=NPOINT(4),NEND
15182 IF (ABS(ISTHKK(I)).EQ.1) THEN
15187 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15188 IF (NSEC.GT.1) THEN
15190 IDHAD = IDT_IPDGHA(IDXOUT(N))
15191 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15192 & POUT(N,3),POUT(N,4),0,0,0)
15201 *===decpi0=============================================================*
15203 CDECK ID>, DT_DECPI0
15204 SUBROUTINE DT_DECPI0
15206 ************************************************************************
15207 * Decay of pi0 handled with JETSET. *
15208 * This version dated 18.02.96 is written by S. Roesler *
15209 ************************************************************************
15211 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15214 PARAMETER ( LINP = 5 ,
15218 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15222 PARAMETER (NMXHKK=200000)
15224 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15225 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15226 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15227 * extended event history
15228 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15229 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15232 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15234 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15236 PARAMETER (MAXLND=4000)
15237 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15239 * flags for input different options
15240 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15241 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15242 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15246 DIMENSION IHISMO(NMXHKK),P1(4)
15248 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15260 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15266 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15267 & PHKK(4,I),INI,IDUM,IDUM)
15268 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15269 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15270 COSTH = PHKK(3,I)/(PTOT+TINY10)
15271 IF (COSTH.GT.ONE) THEN
15273 ELSEIF (COSTH.LT.-ONE) THEN
15274 THETA = TWOPI/2.0D0
15276 THETA = ACOS(COSTH)
15278 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15279 IF (PHKK(1,I).LT.0.0D0)
15281 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15287 P(NN,5) = PHKK(5,I)
15289 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15303 IF (PYK(II,7).EQ.1) THEN
15307 P1(KK) = PYP(II,KK)
15312 MO = IHISMO(PYK(II,15))
15314 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15316 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15318 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15322 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15329 *===dtwopd=============================================================*
15331 CDECK ID>, DT_DTWOPD
15332 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15333 & COF2,SIF2,AM1,AM2)
15335 ************************************************************************
15336 * Two-particle decay. *
15337 * UMO cm-energy of the decaying system (input) *
15338 * AM1/AM2 masses of the decay products (input) *
15339 * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15340 * COD,COF,SIF direction cosines of the decay prod. (output) *
15341 * Revised by S. Roesler, 20.11.95 *
15342 ************************************************************************
15344 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15347 PARAMETER ( LINP = 5 ,
15351 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15353 IF (UMO.LT.(AM1+AM2)) THEN
15354 WRITE(LOUT,1000) UMO,AM1,AM2
15355 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15360 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15362 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15364 CALL DT_DSFECF(SIF1,COF1)
15365 COD1 = TWO*DT_RNDM(PCM2)-ONE
15373 *===dthrep=============================================================*
15375 CDECK ID>, DT_DTHREP
15376 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15377 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15379 ************************************************************************
15380 * Three-particle decay. *
15381 * UMO cm-energy of the decaying system (input) *
15382 * AM1/2/3 masses of the decay products (input) *
15383 * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15384 * COD,COF,SIF direction cosines of the decay prod. (output) *
15386 * Threpd89: slight revision by A. Ferrari *
15387 * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15388 * Revised by S. Roesler, 20.11.95 *
15389 ************************************************************************
15391 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15394 PARAMETER ( LINP = 5 ,
15398 PARAMETER ( ANGLSQ = 2.5D-31 )
15399 PARAMETER ( AZRZRZ = 1.0D-30 )
15400 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15401 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15402 PARAMETER ( ONEONE = 1.D+00 )
15403 PARAMETER ( TWOTWO = 2.D+00 )
15404 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15406 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15407 * flags for input different options
15408 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15409 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15410 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15412 DIMENSION F(5),XX(5)
15416 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15417 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15418 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15425 * UFAK=1.0000000000001D0
15426 * IF (GU.GT.GO) UFAK=0.9999999999999D0
15444 S22=GU+(I-1.D0)*DS2
15446 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15448 IF(RHO2.LT.RHO1) GO TO 125
15450 125 S2SUP=(S22-S21)*.5D0+S21
15451 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15453 SUPRHO=SUPRHO*1.05D0
15455 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15456 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15462 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15463 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15465 X4=(XX(1)+XX(2))*0.5D0
15466 X5=(XX(2)+XX(3))*0.5D0
15467 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15469 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15476 IF (F (II).GE.F (III)) GO TO 128
15489 IF (XX(II).GE.XX(III)) GO TO 129
15503 IF (ITH.GT.200) REDU=-9.D0
15504 IF (ITH.GT.200) GO TO 400
15506 * S2=AM23+C*((UMO-AM1)**2-AM23)
15507 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15510 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15511 IF(Y.GT.RHO) GO TO 1
15512 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15514 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15516 S3=UMO2+AM11+AM22+AM33-S1-S2
15517 ECM1=(UMO2+AM11-S2)/UMOO
15518 ECM2=(UMO2+AM22-S3)/UMOO
15519 ECM3=(UMO2+AM33-S1)/UMOO
15520 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15521 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15522 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15523 CALL DT_DSFECF(SFE,CFE)
15524 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15525 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15526 PCM12 = PCM1 * PCM2
15527 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15528 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15532 COSTH=(UW-0.5D+00)*2.D+00
15534 * IF(ABS(COSTH).GT.0.9999999999999999D0)
15535 * &COSTH=SIGN(0.9999999999999999D0,COSTH)
15536 IF(ABS(COSTH).GT.ONEONE)
15537 &COSTH=SIGN(ONEONE,COSTH)
15538 IF (REDU.LT.1.D+00) RETURN
15539 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15540 * IF(ABS(COSTH2).GT.0.9999999999999999D0)
15541 * &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15542 IF(ABS(COSTH2).GT.ONEONE)
15543 &COSTH2=SIGN(ONEONE,COSTH2)
15544 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15545 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15546 SINTH1=COSTH2*SINTH-COSTH*SINTH2
15547 COSTH1=COSTH*COSTH2+SINTH2*SINTH
15548 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15549 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15550 C***THE DIRECTION OF PARTICLE 3
15551 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15558 CALL DT_DSFECF(SIF3,COF3)
15559 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15560 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15562 COD1=CX11*COD3+CZ11*SID3
15563 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15564 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15567 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15568 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15569 COD2=CX22*COD3+CZ22*SID3
15570 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15571 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15572 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15574 * === Energy conservation check: === *
15575 EOCHCK = UMO - ECM1 - ECM2 - ECM3
15576 * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15577 * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15578 * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15579 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15580 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15581 & + PCM3 * COF3 * SID3
15582 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15583 & + PCM3 * SIF3 * SID3
15584 EOCMPR = 1.D-12 * UMO
15585 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15586 & .GT. EOCMPR ) THEN
15587 **sr 5.5.95 output-unit changed
15588 IF (IOULEV(1).GT.0) THEN
15590 & ' *** Threpd: energy/momentum conservation failure! ***',
15591 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
15592 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15599 *===dbklas=============================================================*
15601 CDECK ID>, DT_DBKLAS
15602 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15604 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15607 PARAMETER ( LINP = 5 ,
15611 * quark-content to particle index conversion (DTUNUC 1.x)
15612 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15613 & IA08(6,21),IA10(6,21)
15618 CALL DT_INDEXD(J,K,IND)
15621 IF (I8.LE.0) I8 = I10
15628 CALL DT_INDEXD(JJ,KK,IND)
15631 IF (I8.LE.0) I8 = I10
15636 *===indexd=============================================================*
15638 CDECK ID>, DT_INDEXD
15639 SUBROUTINE DT_INDEXD(KA,KB,IND)
15641 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15644 PARAMETER ( LINP = 5 ,
15653 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15655 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15656 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15657 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15659 IF (KP.EQ.10) IND=10
15660 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15661 IF (KP.EQ.9) IND=12
15662 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15663 IF (KP.EQ.15) IND=14
15664 IF (KP.EQ.18) IND=15
15665 IF (KP.EQ.16) IND=16
15666 IF (KP.EQ.20) IND=17
15667 IF (KP.EQ.24) IND=18
15668 IF (KP.EQ.25) IND=19
15669 IF (KP.EQ.30) IND=20
15670 IF (KP.EQ.36) IND=21
15675 *===dchant=============================================================*
15677 CDECK ID>, DT_DCHANT
15678 SUBROUTINE DT_DCHANT
15680 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15683 PARAMETER ( LINP = 5 ,
15687 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15689 * HADRIN: decay channel information
15690 PARAMETER (IDMAX9=602)
15692 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15693 * particle properties (BAMJET index convention)
15695 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15696 & IICH(210),IIBAR(210),K1(210),K2(210)
15698 DIMENSION HWT(IDMAX9)
15700 * change of weights wt from absolut values into the sum of wt of a dec.
15705 C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15706 C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15707 C & K1(KKK),K2(KKK)
15718 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15719 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15729 *===ddatar=============================================================*
15731 CDECK ID>, DT_DDATAR
15732 SUBROUTINE DT_DDATAR
15734 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15737 PARAMETER ( LINP = 5 ,
15741 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15743 * quark-content to particle index conversion (DTUNUC 1.x)
15744 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15745 & IA08(6,21),IA10(6,21)
15747 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15749 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
15750 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
15752 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
15753 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
15755 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
15756 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
15757 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
15758 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
15759 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
15760 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
15761 & 0, 0, 0,140,137,138,146, 0, 0,142,
15762 & 139,147, 0, 0,145,148, 50*0/
15763 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
15764 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
15765 & 0, 54, 55,105,162, 0, 0, 56,106,163,
15766 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
15767 & 0, 0,104,105,107,164, 0, 0,106,108,
15768 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
15769 & 0, 0, 0,161,162,164,167, 0, 0,163,
15770 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
15771 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
15772 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
15773 & 0, 2, 9,100,149, 0, 0, 0,101,154,
15774 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
15775 & 0, 0, 99,100,102,150, 0, 0,101,103,
15776 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
15777 & 0, 0, 0,152,149,150,158, 0, 0,154,
15778 & 151,159, 0, 0,157,160, 50*0/
15779 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
15780 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
15781 & 0, 68, 69,111,172, 0, 0, 70,112,173,
15782 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
15783 & 0, 0,110,111,113,174, 0, 0,112,114,
15784 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
15785 & 0, 0, 0,171,172,174,177, 0, 0,173,
15786 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
15822 *===initjs=============================================================*
15824 CDECK ID>, DT_INITJS
15825 SUBROUTINE DT_INITJS(MODE)
15827 ************************************************************************
15828 * Initialize JETSET paramters. *
15829 * MODE = 0 default settings *
15830 * = 1 PHOJET settings *
15831 * = 2 DTUNUC settings *
15832 * This version dated 16.02.96 is written by S. Roesler *
15833 ************************************************************************
15835 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15838 PARAMETER ( LINP = 5 ,
15842 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15844 LOGICAL LFIRST,LFIRDT,LFIRPH
15846 INCLUDE './flukapro/(DIMPAR)'
15847 INCLUDE './flukapro/(PART)'
15849 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15851 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15853 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15855 * flags for particle decays
15856 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15857 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15858 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15859 * flags for input different options
15860 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15861 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15862 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15866 DIMENSION IDXSTA(40)
15868 * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
15869 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15870 * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
15871 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
15872 * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15873 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15874 * Ksic0 aKsic+aKsic0 sig0 asig0
15875 & 4132,-4232,-4132, 3212,-3212, 5*0/
15877 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15880 * save default settings
15892 * LUJETS / PYJETS array-dimensions
15896 * increase maximum number of JETSET-error prints
15898 * prevent particles decaying
15902 KC = PYCOMP(IDXSTA(I))
15909 C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15910 C & (I.EQ.8).OR.(I.EQ.10)) THEN
15911 C ELSEIF (I.EQ.4) THEN
15917 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15919 KC = PYCOMP(IDXSTA(I))
15926 * as Fluka event-generator: allow only paprop particles to be stable
15927 * and let all other particles decay (i.e. those with strong decays)
15928 IF (ITRSPT.EQ.1) THEN
15930 IF (KPTOIP(I).NE.0) THEN
15935 IF (MDCY(KC,1).EQ.1) THEN
15936 WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
15937 & 'transport : particle should not ',
15938 & 'decay : ',IDPDG,' ',ANAME(I)
15947 IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
15948 & (ANAME(KP).NE.'BLANK ').AND.
15949 & (ANAME(KP).NE.'RNDFLV ')) THEN
15950 WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
15951 & 'transport: particle should decay ',
15952 & ': ',IDPDG,' ',ANAME(KP)
15961 IF (PDB.LE.ZERO) THEN
15962 * no popcorn-mechanism
15968 * set JETSET-parameter requested by input cards
15969 IF (NMSTU.GT.0) THEN
15971 MSTU(IMSTU(I)) = MSTUX(I)
15974 IF (NMSTJ.GT.0) THEN
15976 MSTJ(IMSTJ(I)) = MSTJX(I)
15979 IF (NPARU.GT.0) THEN
15981 PARU(IPARU(I)) = PARUX(I)
15987 * PARJ(1) suppression of qq-aqaq pair prod. compared to
15988 * q-aq pair prod. (default: 0.1)
15989 * PARJ(2) strangeness suppression (default: 0.3)
15990 * PARJ(3) extra suppression of strange diquarks (default: 0.4)
15991 * PARJ(6) extra suppression of sas-pair shared by B and
15992 * aB in BMaB (default: 0.5)
15993 * PARJ(7) extra suppression of strange meson M in BMaB
15994 * configuration (default: 0.5)
15995 * PARJ(18) spin 3/2 baryon suppression (default: 1.0)
15996 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15997 * momentum distrib. for prim. hadrons (default: 0.35)
15998 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15999 * function (default: 0.9 GeV^-2)
16002 IF (MODE.EQ.1) THEN
16009 C PARJ(18) = PDEF18
16010 C PARJ(21) = PDEF21
16011 C PARJ(42) = PDEF42
16012 **sr 18.11.98 parameter tuning
16013 C PARJ(1) = 0.092D0
16017 C PARJ(21) = 0.45D0
16019 **sr 28.04.99 parameter tuning (May 99 minor modifications)
16029 IF (NPARJ.GT.0) THEN
16031 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16035 C *** Commented by Chiara
16036 C WRITE(LOUT,'(1X,A)')
16037 C & 'DT_INITJS: JETSET-parameter for PHOJET'
16042 ELSEIF (MODE.EQ.2) THEN
16043 IF (IFRAG(2).EQ.1) THEN
16044 **sr parameters before 9.3.96
16049 C PARJ(21) = 0.55D0
16051 **sr 18.11.98 parameter tuning
16056 C PARJ(21) = 0.45D0
16058 **sr 28.04.99 parameter tuning
16066 IF (NPARJ.GT.0) THEN
16068 IF (IPARJ(I).LT.0) THEN
16069 IDX = ABS(IPARJ(I))
16070 PARJ(IDX) = PARJX(I)
16075 WRITE(LOUT,'(1X,A)')
16076 & 'DT_INITJS: JETSET-parameter for DTUNUC'
16080 ELSEIF (IFRAG(2).EQ.2) THEN
16087 C PARJ(21) = 0.55D0
16118 *===jspara=============================================================*
16120 CDECK ID>, DT_JSPARA
16121 SUBROUTINE DT_JSPARA(MODE)
16123 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16126 PARAMETER ( LINP = 5 ,
16130 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16131 & ONE=1.0D0,ZERO=0.0D0)
16135 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16137 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16139 DATA LFIRST /.TRUE./
16141 * save the default JETSET-parameter on the first call
16152 C *** Commented by Chiara
16154 C 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16156 * compare the default JETSET-parameter with the present values
16158 C *** Commented by Chiara
16159 C IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16160 C WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16161 CC ISTU(I) = MSTU(I)
16163 DIFF = ABS(PARU(I)-QARU(I))
16164 C *** Commented by Chiara
16165 C IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16166 C WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16167 CC QARU(I) = PARU(I)
16169 C *** Commented by Chiara
16170 C IF (MSTJ(I).NE.ISTJ(I)) THEN
16171 C WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16172 CC ISTJ(I) = MSTJ(I)
16174 DIFF = ABS(PARJ(I)-QARJ(I))
16175 C *** Commented by Chiara
16176 C IF (DIFF.GE.1.0D-5) THEN
16177 C WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16178 CC QARJ(I) = PARJ(I)
16181 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16182 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16187 *===fozoca=============================================================*
16189 CDECK ID>, DT_FOZOCA
16190 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16192 ************************************************************************
16193 * This subroutine treats the complete FOrmation ZOne supressed intra- *
16194 * nuclear CAscade. *
16195 * LFZC = .true. cascade has been treated *
16196 * = .false. cascade skipped *
16197 * This is a completely revised version of the original FOZOKL. *
16198 * This version dated 18.11.95 is written by S. Roesler *
16199 ************************************************************************
16201 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16204 PARAMETER ( LINP = 5 ,
16208 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16209 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16211 LOGICAL LSTART,LCAS,LFZC
16215 PARAMETER (NMXHKK=200000)
16217 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16218 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16219 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16220 * extended event history
16221 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16222 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16224 * rejection counter
16225 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16226 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16227 & IREXCI(3),IRDIFF(2),IRINC
16228 * properties of interacting particles
16229 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16230 * Glauber formalism: collision properties
16231 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16232 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16233 * flags for input different options
16234 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16235 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16236 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16237 * final state after intranuclear cascade step
16238 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16239 * parameter for intranuclear cascade
16241 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16243 DIMENSION NCWOUN(2)
16245 DATA LSTART /.TRUE./
16250 * skip cascade if hadron-hadron interaction or if supressed by user
16251 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16252 * skip cascade if not all possible chains systems are hadronized
16254 IF (.NOT.LHADRO(I)) GOTO 9999
16258 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16259 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16260 & 'maximum of',I4,' generations',/,10X,'formation time ',
16261 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16262 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16263 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16264 1001 FORMAT(10X,'p_t dependent formation zone',/)
16265 1002 FORMAT(10X,'constant formation zone',/)
16269 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16270 * which may interact with final state particles are stored in a seperate
16271 * array - here all proj./target nucleon-indices (just for simplicity)
16273 DO 9 I=1,NPOINT(1)-1
16278 * initialize Pauli-principle treatment (find wounded nucleons)
16285 IF (ISTHKK(J).EQ.10+I) THEN
16286 NWOUND(I) = NWOUND(I)+1
16287 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16288 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16293 * modify nuclear potential for wounded nucleons
16294 IPRCL = IP -NWOUND(1)
16295 IPZRCL = IPZ-NCWOUN(1)
16296 ITRCL = IT -NWOUND(2)
16297 ITZRCL = ITZ-NCWOUN(2)
16298 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16306 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16307 * select nucleus the cascade starts first (proj. - 1, target - -1)
16309 * projectile/target with probab. 1/2
16310 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16311 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16312 * in the nucleus with highest mass
16313 ELSEIF (INCMOD.EQ.2) THEN
16316 ELSEIF (IP.EQ.IT) THEN
16317 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16319 * the nucleus the cascade starts first is requested to be the one
16320 * moving in the direction of the secondary
16321 ELSEIF (INCMOD.EQ.3) THEN
16322 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16324 * check that the selected "nucleus" is not a hadron
16325 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16326 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
16328 * treat intranuclear cascade in the nucleus selected first
16330 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16331 IF (IREJ1.NE.0) GOTO 9998
16332 * treat intranuclear cascade in the other nucleus if this isn't a had.
16334 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16335 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
16336 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16337 IF (IREJ1.NE.0) GOTO 9998
16345 IF (NSTART.LE.NEND) GOTO 7
16350 * reject this event
16355 * intranucl. cascade not treated because of interaction properties or
16356 * it is supressed by user or it was rejected or...
16358 * reset flag characterizing direction of motion in n-n-cms
16360 C DO 9990 I=NPOINT(5),NHKK
16361 C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16367 *===inucas=============================================================*
16369 CDECK ID>, DT_INUCAS
16370 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16372 ************************************************************************
16373 * Formation zone supressed IntraNUclear CAScade for one final state *
16375 * IT, IP mass numbers of target, projectile nuclei *
16376 * IDXCAS index of final state particle in DTEVT1 *
16377 * NCAS = 1 intranuclear cascade in projectile *
16378 * = -1 intranuclear cascade in target *
16379 * This version dated 18.11.95 is written by S. Roesler *
16380 ************************************************************************
16382 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16385 PARAMETER ( LINP = 5 ,
16389 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16390 & OHALF=0.5D0,ONE=1.0D0)
16391 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16392 PARAMETER (TWOPI=6.283185307179586454D+00)
16393 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16395 LOGICAL LABSOR,LCAS
16399 PARAMETER (NMXHKK=200000)
16401 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16402 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16403 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16404 * extended event history
16405 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16406 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16408 * final state after inc step
16409 PARAMETER (MAXFSP=10)
16410 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16411 * flags for input different options
16412 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16413 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16414 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16415 * particle properties (BAMJET index convention)
16417 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16418 & IICH(210),IIBAR(210),K1(210),K2(210)
16419 * Glauber formalism: collision properties
16420 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16421 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16422 * nuclear potential
16424 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16425 & EBINDP(2),EBINDN(2),EPOT(2,210),
16426 & ETACOU(2),ICOUL,LFERMI
16427 * parameter for intranuclear cascade
16429 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16430 * final state after intranuclear cascade step
16431 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16432 * nucleon-nucleon event-generator
16435 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16436 * statistics: residual nuclei
16437 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16438 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16439 & NINCST(2,4),NINCEV(2),
16440 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16441 & NRESPB(2),NRESCH(2),NRESEV(4),
16442 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16445 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16446 & PCAS1(5),PNUC(5),BGTA(4),
16447 & BGCAS(2),GACAS(2),BECAS(2),
16448 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16450 DATA PDIF /0.545D0/
16455 IF (NINCEV(1).NE.NEVHKK) THEN
16457 NINCEV(2) = NINCEV(2)+1
16460 * "BAMJET-index" of this hadron
16461 IDCAS = IDBAM(IDXCAS)
16462 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16464 * skip gammas, electrons, etc..
16465 IF (AAM(IDCAS).LT.TINY2) RETURN
16467 * Lorentz-trsf. into projectile rest system
16469 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16470 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16471 & PCAS(1,4),IDCAS,-2)
16472 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16473 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16474 IF (PCAS(1,5).GT.ZERO) THEN
16475 PCAS(1,5) = SQRT(PCAS(1,5))
16477 PCAS(1,5) = AAM(IDCAS)
16480 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16482 * Lorentz-parameters
16483 * particle rest system --> projectile rest system
16484 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16485 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16486 BECAS(1) = BGCAS(1)/GACAS(1)
16490 IF (K.LE.3) COSCAS(1,K) = ZERO
16497 * Lorentz-trsf. into target rest system
16499 * LEPTO: final state particles are already in target rest frame
16500 C IF (MCGENE.EQ.3) THEN
16501 C PCAS(2,1) = PHKK(1,IDXCAS)
16502 C PCAS(2,2) = PHKK(2,IDXCAS)
16503 C PCAS(2,3) = PHKK(3,IDXCAS)
16504 C PCAS(2,4) = PHKK(4,IDXCAS)
16506 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16507 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16508 & PCAS(2,4),IDCAS,-3)
16510 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16511 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16512 IF (PCAS(2,5).GT.ZERO) THEN
16513 PCAS(2,5) = SQRT(PCAS(2,5))
16515 PCAS(2,5) = AAM(IDCAS)
16518 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16520 * Lorentz-parameters
16521 * particle rest system --> target rest system
16522 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16523 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16524 BECAS(2) = BGCAS(2)/GACAS(2)
16528 IF (K.LE.3) COSCAS(2,K) = ZERO
16536 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16537 * potential (see CONUCL)
16538 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
16539 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
16540 * impact parameter (the projectile moving along z)
16542 BIMPC(2) = BIMPAC*FM2MM
16544 * get position of initial hadron in projectile/target rest-syst.
16546 VTXCAS(1,K) = WHKK(K,IDXCAS)
16547 VTXCAS(2,K) = VHKK(K,IDXCAS)
16552 IF (NCAS.EQ.-1) THEN
16557 IF (PTOCAS(ICAS).LT.TINY10) THEN
16558 WRITE(LOUT,1000) PTOCAS
16559 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
16560 & ' hadron ',/,20X,2E12.4)
16564 * reset spectator flags
16571 * formation length (in fm)
16575 DEL0 = TAUFOR*BGCAS(ICAS)
16576 IF (ITAUVE.EQ.1) THEN
16577 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16578 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16581 * sample from exp(-del/del0)
16582 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16583 * save formation time
16584 TAUSA1 = DEL1/BGCAS(ICAS)
16585 REL1 = TAUSA1*BGCAS(I2)
16588 TAUSAM = DEL/BGCAS(ICAS)
16589 REL = TAUSAM*BGCAS(I2)
16591 * special treatment for negative particles unable to escape
16592 * nuclear potential (implemented for ap, pi-, K- only)
16594 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16595 * threshold energy = nuclear potential + Coulomb potential
16596 * (nuclear potential for hadron-nucleus interactions only)
16597 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16598 IF (PCAS(ICAS,4).LT.ETHR) THEN
16600 PCAS1(K) = PCAS(ICAS,K)
16602 * "absorb" negative particle in nucleus
16603 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16604 IF (IREJ1.NE.0) GOTO 9999
16605 IF (NSPE.GE.1) LABSOR = .TRUE.
16609 * if the initial particle has not been absorbed proceed with
16611 IF (.NOT.LABSOR) THEN
16613 * calculate coordinates of hadron at the end of the formation zone
16614 * transport-time and -step in the rest system where this step is
16617 DTIME = DSTEP/BECAS(ICAS)
16619 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16620 RTIME = RSTEP/BECAS(I2)
16624 * save step whithout considering the overlapping region
16625 DSTEP1 = DEL1*FM2MM
16626 DTIME1 = DSTEP1/BECAS(ICAS)
16627 RSTEP1 = REL1*FM2MM
16628 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16629 RTIME1 = RSTEP1/BECAS(I2)
16633 * transport to the end of the formation zone in this system
16635 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16636 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
16637 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16638 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
16640 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16641 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
16642 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16643 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
16645 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16646 XCAS = VTXCAS(ICAS,1)
16647 YCAS = VTXCAS(ICAS,2)
16648 XNCLTA = BIMPAC*FM2MM
16649 RNCLPR = (RPROJ+RNUCLE)*FM2MM
16650 RNCLTA = (RTARG+RNUCLE)*FM2MM
16651 C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16652 C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16653 C RNCLPR = (RPROJ)*FM2MM
16654 C RNCLTA = (RTARG)*FM2MM
16655 RCASPR = SQRT( XCAS**2 +YCAS**2)
16656 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16657 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16658 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16662 * check if particle is already outside of the corresp. nucleus
16663 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16664 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16665 IF (RDIST.GE.RNUC(ICAS)) THEN
16666 * here: IDCH is the generation of the final state part. starting
16667 * with zero for hadronization products
16668 * flag particles of generation 0 being outside the nuclei after
16669 * formation time (to be used for excitation energy calculation)
16670 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16671 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16680 * already here: skip particles being outside HADRIN "energy-window"
16681 * to avoid wasting of time
16682 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16683 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16684 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16685 C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16686 C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
16687 C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16688 C & E12.4,', above or below HADRIN-thresholds',I6)
16693 DO 7 IDXHKK=1,NOINC
16695 * scan DTEVT1 for unwounded or excited nucleons
16696 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16698 IF (ICAS.EQ.1) THEN
16699 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16700 ELSEIF (ICAS.EQ.2) THEN
16701 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16704 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16705 & VTXDST(2)*COSCAS(ICAS,2)+
16706 & VTXDST(3)*COSCAS(ICAS,3)
16707 * check if nucleon is situated in forward direction
16708 IF (POSNUC.GT.ZERO) THEN
16709 * distance between hadron and this nucleon
16710 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16713 BIMNU2 = DISTNU**2-POSNUC**2
16714 IF (BIMNU2.LT.ZERO) THEN
16715 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16716 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
16717 & ' parameter ',/,20X,3E12.4)
16720 BIMNU = SQRT(BIMNU2)
16721 * maximum impact parameter to have interaction
16722 IDNUC = IDT_ICIHAD(IDHKK(I))
16723 IDNUC1 = IDT_MCHAD(IDNUC)
16724 IDCAS1 = IDT_MCHAD(IDCAS)
16726 PCAS1(K) = PCAS(ICAS,K)
16727 PNUC(K) = PHKK(K,I)
16729 * Lorentz-parameter for trafo into rest-system of target
16731 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16733 * transformation of projectile into rest-system of target
16734 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16735 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16736 & PPTOT,PX,PY,PZ,PE)
16738 C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16739 C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16741 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16742 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16743 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16744 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16745 SIGIN = SIGTOT-SIGEL-SIGAB
16746 C SIGTOT = SIGIN+SIGEL+SIGAB
16748 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16749 * check if interaction is possible
16750 IF (BIMNU.LE.BIMMAX) THEN
16751 * get nucleon with smallest distance and kind of interaction
16752 * (elastic/inelastic)
16753 IF (DISTNU.LT.DIST) THEN
16756 IF (IDNUC.NE.IDSPE(1)) THEN
16757 IDSPE(2) = IDSPE(1)
16758 IDXSPE(2) = IDXSPE(1)
16767 C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16769 C STOT = SIGIN+SIGEL
16771 C SELA = SIGEL+0.75D0*SIGIN
16772 C STOT = 0.25D0*SIGIN+SELA
16778 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16780 IDNUC = IDT_ICIHAD(IDHKK(I))
16781 IF (IDNUC.EQ.1) THEN
16782 IF (DISTNU.LT.DISTP) THEN
16787 ELSEIF (IDNUC.EQ.8) THEN
16788 IF (DISTNU.LT.DISTN) THEN
16797 * there is no nucleon for a secondary interaction
16798 IF (NSPE.EQ.0) GOTO 9997
16800 C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16801 C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16802 IF (IDXSPE(2).EQ.0) THEN
16803 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16805 C IF (ICAS.EQ.1) THEN
16806 C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16807 C ELSEIF (ICAS.EQ.2) THEN
16808 C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16811 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16813 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16820 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16822 C IF (ICAS.EQ.1) THEN
16823 C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16824 C ELSEIF (ICAS.EQ.2) THEN
16825 C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16828 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16830 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16843 IF (RR.LT.SELA/STOT) THEN
16845 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16852 PCAS1(K) = PCAS(ICAS,K)
16853 PNUC(K) = PHKK(K,IDXSPE(1))
16855 IF (IPROC.EQ.3) THEN
16856 * 2-nucleon absorption of pion
16858 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16859 IF (IREJ1.NE.0) GOTO 9999
16860 IF (NSPE.GE.1) LABSOR = .TRUE.
16862 * sample secondary interaction
16863 IDNUC = IDBAM(IDXSPE(1))
16864 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16865 IF (IREJ1.EQ.1) GOTO 9999
16866 IF (IREJ1.GT.1) GOTO 9998
16870 * update arrays to include Pauli-principle
16872 IF (NWOUND(ICAS).LE.299) THEN
16873 NWOUND(ICAS) = NWOUND(ICAS)+1
16874 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16878 * dump initial hadron for energy-momentum conservation check
16880 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16881 & PCAS(ICAS,4),1,IDUM,IDUM)
16883 * dump final state particles into DTEVT1
16885 * check if Pauli-principle is fulfilled
16887 NWTMP(1) = NWOUND(1)
16888 NWTMP(2) = NWOUND(2)
16892 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16893 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16895 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16902 IF (IDX.EQ.1) MODE = -1
16903 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16905 * first check if cascade step is forbidden due to Pauli-principle
16906 * (in case of absorpion this step is forced)
16907 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16908 & (IDFSP(I).EQ.8))) THEN
16909 * get nuclear potential barrier
16910 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16911 IF (IDFSP(I).EQ.1) THEN
16912 POTLOW = POT-EBINDP(IDX)
16914 POTLOW = POT-EBINDN(IDX)
16916 * final state particle not able to escape nucleus
16917 IF (PE.LE.POTLOW) THEN
16918 * check if there are wounded nucleons
16919 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16920 & EWOUND(IDX,NWOUND(IDX)))) THEN
16922 NWOUND(IDX) = NWOUND(IDX)-1
16924 * interaction prohibited by Pauli-principle
16925 NWOUND(1) = NWTMP(1)
16926 NWOUND(2) = NWTMP(2)
16935 NWOUND(1) = NWTMP(1)
16936 NWOUND(2) = NWTMP(2)
16940 IST = ISTHKK(IDXCAS)
16944 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16945 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16947 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16952 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16954 * first check if cascade step is forbidden due to Pauli-principle
16955 * (in case of absorpion this step is forced)
16956 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16957 & (IDFSP(I).EQ.8))) THEN
16958 * get nuclear potential barrier
16959 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16960 IF (IDFSP(I).EQ.1) THEN
16961 POTLOW = POT-EBINDP(IDX)
16963 POTLOW = POT-EBINDN(IDX)
16965 * final state particle not able to escape nucleus
16966 IF (PE.LE.POTLOW) THEN
16967 * check if there are wounded nucleons
16968 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16969 & EWOUND(IDX,NWOUND(IDX)))) THEN
16970 NWOUND(IDX) = NWOUND(IDX)-1
16974 * interaction prohibited by Pauli-principle
16975 NWOUND(1) = NWTMP(1)
16976 NWOUND(2) = NWTMP(2)
16980 c ELSEIF (PE.LE.POT) THEN
16981 cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16982 cC NWOUND(IDX) = NWOUND(IDX)-1
16984 c NPAULI = NPAULI+1
16990 * dump final state particles for energy-momentum conservation check
16991 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16992 & -PFSP(4,I),2,IDUM,IDUM)
16998 IF (ABS(IST).EQ.1) THEN
16999 * transform particles back into n-n cms
17000 * LEPTO: leave final state particles in target rest frame
17001 C IF (MCGENE.EQ.3) THEN
17008 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17009 & PFSP(4,I),IDFSP(I),IMODE)
17011 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17012 * target cascade but fsp got stuck in proj. --> transform it into
17013 * proj. rest system
17014 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17015 & PFSP(4,I),IDFSP(I),-1)
17016 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17017 * proj. cascade but fsp got stuck in target --> transform it into
17018 * target rest system
17019 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17020 & PFSP(4,I),IDFSP(I),1)
17023 * dump final state particles into DTEVT1
17024 IGEN = IDCH(IDXCAS)+1
17025 ID = IDT_IPDGHA(IDFSP(I))
17027 IF (LABSOR) IXR = 99
17028 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17029 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17031 * update the counter for particles which got stuck inside the nucleus
17032 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17034 IDXINC(NOINC) = NHKK
17037 * in case of absorption the spatial treatment is an approximate
17038 * solution anyway (the positions of the nucleons which "absorb" the
17039 * cascade particle are not taken into consideration) therefore the
17040 * particles are produced at the position of the cascade particle
17042 WHKK(K,NHKK) = WHKK(K,IDXCAS)
17043 VHKK(K,NHKK) = VHKK(K,IDXCAS)
17046 * DDISTL - distance the cascade particle moves to the intera. point
17047 * (the position where impact-parameter = distance to the interacting
17048 * nucleon), DIST - distance to the interacting nucleon at the time of
17049 * formation of the cascade particle, BINT - impact-parameter of this
17050 * cascade-interaction
17051 DDISTL = SQRT(DIST**2-BINT**2)
17052 DTIME = DDISTL/BECAS(ICAS)
17053 DTIMEL = DDISTL/BGCAS(ICAS)
17054 RDISTL = DTIMEL*BGCAS(I2)
17055 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17056 RTIME = RDISTL/BECAS(I2)
17060 * RDISTL, RTIME are this step and time in the rest system of the other
17063 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17064 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
17066 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17067 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
17068 * position of particle production is half the impact-parameter to
17069 * the interacting nucleon
17071 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17072 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17074 * time of production of secondary = time of interaction
17075 WHKK(4,NHKK) = VTXCA1(1,4)
17076 VHKK(4,NHKK) = VTXCA1(2,4)
17081 * modify status and position of cascade particle (the latter for
17082 * statistics reasons only)
17084 IF (LABSOR) ISTHKK(IDXCAS) = 19
17085 IF (.NOT.LABSOR) THEN
17087 WHKK(K,IDXCAS) = VTXCA1(1,K)
17088 VHKK(K,IDXCAS) = VTXCA1(2,K)
17094 * dump interacting nucleons for energy-momentum conservation check
17096 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17098 * modify entry for interacting nucleons
17099 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17100 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17102 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17103 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17107 * check energy-momentum conservation
17109 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17110 IF (IREJ1.NE.0) GOTO 9999
17115 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17117 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17118 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17125 * transport-step but no cascade step due to configuration (i.e. there
17126 * is no nucleon for interaction etc.)
17129 C WHKK(K,IDXCAS) = VTXCAS(1,K)
17130 C VHKK(K,IDXCAS) = VTXCAS(2,K)
17131 WHKK(K,IDXCAS) = VTXCA1(1,K)
17132 VHKK(K,IDXCAS) = VTXCA1(2,K)
17137 * no cascade-step because of configuration
17138 * (i.e. hadron outside nucleus etc.)
17148 *===absorp=============================================================*
17150 CDECK ID>, DT_ABSORP
17151 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17153 ************************************************************************
17154 * Two-nucleon absorption of antiprotons, pi-, and K-. *
17155 * Antiproton absorption is handled by HADRIN. *
17156 * The following channels for meson-absorption are considered: *
17157 * pi- + p + p ---> n + p *
17158 * pi- + p + n ---> n + n *
17159 * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
17160 * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
17161 * K- + p + p ---> sigma- + n *
17162 * IDCAS, PCAS identity, momentum of particle to be absorbed *
17163 * NCAS = 1 intranuclear cascade in projectile *
17164 * = -1 intranuclear cascade in target *
17165 * NSPE number of spectator nucleons involved *
17166 * IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
17167 * Revised version of the original STOPIK written by HJM and J. Ranft. *
17168 * This version dated 24.02.95 is written by S. Roesler *
17169 ************************************************************************
17171 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17174 PARAMETER ( LINP = 5 ,
17178 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17179 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17183 PARAMETER (NMXHKK=200000)
17185 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17186 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17187 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17188 * extended event history
17189 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17190 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17192 * flags for input different options
17193 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17194 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17195 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17196 * final state after inc step
17197 PARAMETER (MAXFSP=10)
17198 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17199 * particle properties (BAMJET index convention)
17201 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17202 & IICH(210),IIBAR(210),K1(210),K2(210)
17204 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17205 & PTOT3P(4),BG3P(4),
17206 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17211 * skip particles others than ap, pi-, K- for mode=0
17212 IF ((MODE.EQ.0).AND.
17213 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17214 * skip particles others than pions for mode=1
17215 * (2-nucleon absorption in intranuclear cascade)
17216 IF ((MODE.EQ.1).AND.
17217 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17220 IF (NUCAS.EQ.-1) NUCAS = 2
17222 IF (MODE.EQ.0) THEN
17223 * scan spectator nucleons for nucleons being able to "absorb"
17228 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17231 IDSPE(NSPE) = IDBAM(I)
17232 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17233 IF (NSPE.EQ.2) THEN
17234 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17235 & (IDSPE(2).EQ.8)) THEN
17236 * there is no pi-+n+n channel
17248 * transform excited projectile nucleons (status=15) into proj. rest s.
17251 PSPE(I,K) = PHKK(K,IDXSPE(I))
17255 * antiproton absorption
17256 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17258 PSPE1(K) = PSPE(1,K)
17260 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17261 IF (IREJ1.NE.0) GOTO 9999
17264 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17265 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17266 IF (IDCAS.EQ.14) THEN
17270 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17271 ELSEIF (IDCAS.EQ.13) THEN
17275 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17276 ELSEIF (IDCAS.EQ.23) THEN
17278 IDFSP(1) = IDSPE(1)
17279 IDFSP(2) = IDSPE(2)
17280 ELSEIF (IDCAS.EQ.16) THEN
17283 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17284 IF (R.LT.ONETHI) THEN
17287 ELSEIF (R.LT.TWOTHI) THEN
17294 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17298 IF (R.LT.ONETHI) THEN
17301 ELSEIF (R.LT.TWOTHI) THEN
17310 * dump initial particles for energy-momentum cons. check
17312 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17313 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17315 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17318 * get Lorentz-parameter of 3 particle initial state
17320 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17322 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17323 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17325 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17327 * 2-particle decay of the 3-particle compound system
17328 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17329 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17330 & AAM(IDFSP(1)),AAM(IDFSP(2)))
17332 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17333 PX = PCMF(I)*COFF(I)*SDF
17334 PY = PCMF(I)*SIFF(I)*SDF
17335 PZ = PCMF(I)*CODF(I)
17336 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17337 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17339 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17340 * check consistency of kinematics
17341 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17342 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17343 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
17344 & ' tree-particle kinematics',/,20X,'id: ',I3,
17345 & ' AAM = ',E10.4,' MFSP = ',E10.4)
17347 * dump final state particles for energy-momentum cons. check
17348 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17349 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17353 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17354 IF (IREJ1.NE.0) THEN
17355 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17361 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17362 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
17363 & ' impossible',/,20X,'too few spectators (',I2,')')
17370 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17375 *===hadrin=============================================================*
17377 CDECK ID>, DT_HADRIN
17378 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17380 ************************************************************************
17381 * Interface to the HADRIN-routines for inelastic and elastic *
17383 * IDPR,PPR(5) identity, momentum of projectile *
17384 * IDTA,PTA(5) identity, momentum of target *
17385 * MODE = 1 inelastic interaction *
17386 * = 2 elastic interaction *
17387 * Revised version of the original FHAD. *
17388 * This version dated 27.10.95 is written by S. Roesler *
17389 ************************************************************************
17391 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17394 PARAMETER ( LINP = 5 ,
17398 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17399 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17401 LOGICAL LCORR,LMSSG
17403 * flags for input different options
17404 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17405 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17406 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17407 * final state after inc step
17408 PARAMETER (MAXFSP=10)
17409 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17410 * particle properties (BAMJET index convention)
17412 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17413 & IICH(210),IIBAR(210),K1(210),K2(210)
17414 * output-common for DHADRI/ELHAIN
17415 * final state from HADRIN interaction
17416 PARAMETER (MAXFIN=10)
17417 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17418 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17420 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17421 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17423 DATA LMSSG /.TRUE./
17432 * dump initial particles for energy-momentum cons. check
17434 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17435 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17438 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17439 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17440 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17441 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17442 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17443 IF (LMSSG.AND.(IOULEV(3).GT.0))
17444 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17445 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
17446 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17447 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17452 * convert initial state particles into particles which can be
17453 * handled by HADRIN
17456 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17457 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17464 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17465 IF (IREJ1.GT.0) THEN
17466 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17473 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17474 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17477 * Lorentz-parameter for trafo into rest-system of target
17479 BGTA(K) = PTA(K)/PTA(5)
17481 * transformation of projectile into rest-system of target
17482 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17483 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17486 * direction cosines of projectile in target rest system
17487 CX = PPR1(1)/PPRTO1
17488 CY = PPR1(2)/PPRTO1
17489 CZ = PPR1(3)/PPRTO1
17491 * sample inelastic interaction
17492 IF (MODE.EQ.1) THEN
17493 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17494 IF (IRH.EQ.1) GOTO 9998
17495 * sample elastic interaction
17496 ELSEIF (MODE.EQ.2) THEN
17497 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17498 IF (IREJ1.NE.0) THEN
17499 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17502 IF (IRH.EQ.1) GOTO 9998
17504 WRITE(LOUT,1001) MODE,INTHAD
17505 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
17506 & I4,' (INTHAD =',I4,')')
17510 * transform final state particles back into Lab.
17513 PX = CXRH(I)*PLRH(I)
17514 PY = CYRH(I)*PLRH(I)
17515 PZ = CZRH(I)*PLRH(I)
17516 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17517 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17518 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17519 IDFSP(NFSP) = ITRH(I)
17520 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17522 IF (AMFSP2.LT.-TINY3) THEN
17523 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17524 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17525 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
17526 & I2,') with negative mass^2',/,1X,5E12.4)
17529 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17530 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17531 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17533 1003 FORMAT(1X,'HADRIN: warning! final state particle',
17534 & ' (id = ',I2,') with inconsistent mass',/,1X,
17537 IF (KCORR.GT.2) GOTO 9999
17538 IMCORR(KCORR) = NFSP
17541 * dump final state particles for energy-momentum cons. check
17542 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17543 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17546 * transform momenta on mass shell in case of inconsistencies in
17548 IF (KCORR.GT.0) THEN
17549 IF (KCORR.EQ.2) THEN
17553 IF (IMCORR(1).EQ.1) THEN
17561 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17562 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17563 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17564 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17566 P1IN(K) = PFSP(K,I1)
17567 P2IN(K) = PFSP(K,I2)
17569 XM1 = AAM(IDFSP(I1))
17570 XM2 = AAM(IDFSP(I2))
17571 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17572 IF (IREJ1.GT.0) THEN
17573 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17577 PFSP(K,I1) = P1OUT(K)
17578 PFSP(K,I2) = P2OUT(K)
17580 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17581 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
17582 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17583 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
17584 * dump final state particles for energy-momentum cons. check
17585 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17586 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17587 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17588 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17591 * check energy-momentum conservation
17593 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17594 IF (IREJ1.NE.0) GOTO 9999
17608 *===hadcol=============================================================*
17610 CDECK ID>, DT_HADCOL
17611 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17613 ************************************************************************
17614 * Interface to the HADRIN-routines for inelastic and elastic *
17615 * scattering. This subroutine samples hadron-nucleus interactions *
17616 * below DPM-threshold. *
17617 * IDPROJ BAMJET-index of projectile hadron *
17618 * PPN projectile momentum in target rest frame *
17619 * IDXTAR DTEVT1-index of target nucleon undergoing *
17620 * interaction with projectile hadron *
17621 * This subroutine replaces HADHAD. *
17622 * This version dated 5.5.95 is written by S. Roesler *
17623 ************************************************************************
17625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17628 PARAMETER ( LINP = 5 ,
17632 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17638 PARAMETER (NMXHKK=200000)
17640 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17641 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17642 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17643 * extended event history
17644 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17645 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17647 * nuclear potential
17649 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17650 & EBINDP(2),EBINDN(2),EPOT(2,210),
17651 & ETACOU(2),ICOUL,LFERMI
17652 * interface HADRIN-DPM
17653 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17654 * parameter for intranuclear cascade
17656 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17657 * final state after inc step
17658 PARAMETER (MAXFSP=10)
17659 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17660 * particle properties (BAMJET index convention)
17662 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17663 & IICH(210),IIBAR(210),K1(210),K2(210)
17665 DIMENSION PPROJ(5),PNUC(5)
17667 DATA LSTART /.TRUE./
17674 **sr 6/9/01 commented
17675 C TAUFOR = TAUFOR/2.0D0
17679 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
17680 WRITE(LOUT,1001) TAUFOR
17681 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
17686 IDNUC = IDBAM(IDXTAR)
17687 IDNUC1 = IDT_MCHAD(IDNUC)
17688 IDPRO1 = IDT_MCHAD(IDPROJ)
17690 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17694 C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17695 C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17697 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17698 SIGIN = SIGTOT-SIGEL
17699 C SIGTOT = SIGIN+SIGEL
17702 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17708 PPROJ(5) = AAM(IDPROJ)
17709 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17711 PNUC(K) = PHKK(K,IDXTAR)
17717 IF (ILOOP.GT.100) GOTO 9999
17719 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17720 IF (IREJ1.EQ.1) GOTO 9999
17722 IF (IREJ1.GT.1) THEN
17723 * no interaction possible
17724 * require Pauli blocking
17725 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17726 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17727 IF ((IIBAR(IDPROJ).NE.1).AND.
17728 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
17729 * store incoming particle as final state particle
17730 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17731 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17734 * require Pauli blocking for final state nucleons
17736 IF ((IDFSP(I).EQ.1).AND.
17737 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
17738 IF ((IDFSP(I).EQ.8).AND.
17739 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
17740 IF ((IIBAR(IDFSP(I)).NE.1).AND.
17741 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17743 * store final state particles
17746 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17747 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17748 IDHAD = IDT_IPDGHA(IDFSP(I))
17749 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17750 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17752 IF (I.EQ.1) NPOINT(4) = NHKK
17753 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17754 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17755 VHKK(3,NHKK) = VHKK(3,IDXTAR)
17756 VHKK(4,NHKK) = VHKK(4,IDXTAR)
17757 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17758 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17759 WHKK(3,NHKK) = WHKK(3,1)
17760 WHKK(4,NHKK) = WHKK(4,1)
17772 *===getemu=============================================================*
17774 CDECK ID>, DT_GETEMU
17775 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17777 ************************************************************************
17778 * Sampling of emulsion component to be considered as target-nucleus. *
17779 * This version dated 6.5.95 is written by S. Roesler. *
17780 ************************************************************************
17782 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17785 PARAMETER ( LINP = 5 ,
17789 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17791 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17793 * emulsion treatment
17794 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17796 * Glauber formalism: flags and parameters for statistics
17799 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17801 IF (MODE.EQ.0) THEN
17803 RR = DT_RNDM(SUMFRA)
17806 DO 1 ICOMP=1,NCOMPO
17807 SUMFRA = SUMFRA+EMUFRA(ICOMP)
17808 IF (SUMFRA.GT.RR) THEN
17810 ITZ = IEMUCH(ICOMP)
17817 WRITE(LOUT,'(1X,A,E12.3)')
17818 & 'Warning! norm. failure within emulsion fractions',
17822 ELSEIF (MODE.EQ.1) THEN
17825 IDIFF = ABS(IT-IEMUMA(I))
17826 IF (IDIFF.LT.NDIFF) THEN
17835 * bypass for variable projectile/target/energy runs: the correct
17836 * Glauber data will be always loaded on kkmat=1
17837 IF (IOGLB.EQ.100) THEN
17844 *===nclpot=============================================================*
17846 CDECK ID>, DT_NCLPOT
17847 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17849 ************************************************************************
17850 * Calculation of Coulomb and nuclear potential for a given configurat. *
17851 * IPZ, IP charge/mass number of proj. *
17852 * ITZ, IT charge/mass number of targ. *
17853 * AFERP,AFERT factors modifying proj./target pot. *
17854 * if =0, FERMOD is used *
17855 * MODE = 0 calculation of binding energy *
17856 * = 1 pre-calculated binding energy is used *
17857 * This version dated 16.11.95 is written by S. Roesler. *
17858 ************************************************************************
17860 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17863 PARAMETER ( LINP = 5 ,
17867 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17872 * particle properties (BAMJET index convention)
17874 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17875 & IICH(210),IIBAR(210),K1(210),K2(210)
17876 * nuclear potential
17878 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17879 & EBINDP(2),EBINDN(2),EPOT(2,210),
17880 & ETACOU(2),ICOUL,LFERMI
17882 DIMENSION IDXPOT(14)
17883 * ap an lam alam sig- sig+ sig0 tet0 tet- asig-
17884 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
17885 * asig0 asig+ atet0 atet+
17886 & 100, 101, 102, 103/
17889 DATA LSTART /.TRUE./
17891 IF (MODE.EQ.0) THEN
17903 IF (AFERP.LE.ZERO) FERMIP = FERMOD
17905 IF (AFERT.LE.ZERO) FERMIT = FERMOD
17907 * Fermi momenta and binding energy for projectile
17908 IF ((IP.GT.1).AND.LFERMI) THEN
17909 IF (MODE.EQ.0) THEN
17910 C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17911 C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17915 EBINDP(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ)
17916 & -ENERGY(BIP,BIPZ))
17918 IF (AIP.LE.AIPZ) THEN
17919 EBINDN(1) = EBINDP(1)
17920 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17923 EBINDN(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ)
17924 & -ENERGY(BIP,AIPZ))
17928 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17929 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17934 * effective nuclear potential for projectile
17935 C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17936 C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17937 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17938 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17940 * Fermi momenta and binding energy for target
17941 IF ((IT.GT.1).AND.LFERMI) THEN
17942 IF (MODE.EQ.0) THEN
17943 C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17944 C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17948 EBINDP(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ)
17949 & -ENERGY(BIT,BITZ))
17951 IF (AIT.LE.AITZ) THEN
17952 EBINDN(2) = EBINDP(2)
17953 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17956 EBINDN(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ)
17957 & -ENERGY(BIT,AITZ))
17961 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17962 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17967 * effective nuclear potential for target
17968 C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17969 C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17970 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17971 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17974 EPOT(1,IDXPOT(I)) = EPOT(1,8)
17975 EPOT(2,IDXPOT(I)) = EPOT(2,8)
17981 IF (ICOUL.EQ.1) THEN
17983 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17985 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17989 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17990 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17991 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17993 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
17994 & ,' effects',/,12X,'---------------------------',
17995 & '----------------',/,/,38X,'projectile',
17996 & ' target',/,/,1X,'Mass number / charge',
17997 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
17998 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
17999 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
18000 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
18001 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
18002 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
18009 *===resncl=============================================================*
18011 CDECK ID>, DT_RESNCL
18012 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18014 ************************************************************************
18015 * Treatment of residual nuclei and nuclear effects. *
18016 * MODE = 1 initializations *
18017 * = 2 treatment of final state *
18018 * This version dated 16.11.95 is written by S. Roesler. *
18019 ************************************************************************
18021 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18024 PARAMETER ( LINP = 5 ,
18028 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18029 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18030 & ONETHI=ONE/THREE)
18031 PARAMETER (AMUAMU = 0.93149432D0,
18037 PARAMETER (NMXHKK=200000)
18039 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18040 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18041 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18042 * extended event history
18043 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18044 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18046 * particle properties (BAMJET index convention)
18048 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18049 & IICH(210),IIBAR(210),K1(210),K2(210)
18050 * flags for input different options
18051 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18052 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18053 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18054 * nuclear potential
18056 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18057 & EBINDP(2),EBINDN(2),EPOT(2,210),
18058 & ETACOU(2),ICOUL,LFERMI
18059 * properties of interacting particles
18060 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18061 * properties of photon/lepton projectiles
18062 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18063 * Lorentz-parameters of the current interaction
18064 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18065 & UMO,PPCM,EPROJ,PPROJ
18066 * treatment of residual nuclei: wounded nucleons
18067 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18068 * treatment of residual nuclei: 4-momenta
18069 LOGICAL LRCLPR,LRCLTA
18070 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18071 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18073 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18074 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18075 & IDXCOR(15000),IDXOTH(NMXHKK)
18079 *------- initializations
18082 * initialize arrays for residual nuclei
18097 * correction of projectile 4-momentum for effective target pot.
18098 * and Coulomb-energy (in case of hadron-nucleus interaction only)
18099 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18102 * positively charged hadron - check energy for Coloumb pot.
18103 IF (IICH(IJPROJ).EQ.1) THEN
18104 THRESH = ETACOU(2)+AAM(IJPROJ)
18105 IF (EPNI.LE.THRESH) THEN
18107 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
18108 & ' below Coulomb threshold - event rejected',/)
18112 * negatively charged hadron - increase energy by Coulomb energy
18113 ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18114 EPNI = EPNI+ETACOU(2)
18116 IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18117 * Effective target potential
18118 *sr 6.6. binding energy only (to avoid negative exc. energies)
18119 C EPNI = EPNI+EPOT(2,IJPROJ)
18121 IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18122 & EBIPOT = EBINDN(2)
18123 EPNI = EPNI+ABS(EBIPOT)
18124 * re-initialization of DTLTRA
18127 CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18131 * projectile in n-n cms
18132 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18133 PMASS1 = AAM(IJPROJ)
18135 C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18136 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18138 PM1 = SIGN(PMASS1**2,PMASS1)
18139 PM2 = SIGN(PMASS2**2,PMASS2)
18140 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18142 IF (PMASS1.GT.ZERO) THEN
18143 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18144 & *(PINIPR(4)+PINIPR(5)))
18146 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18151 PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18153 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18154 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18156 PMASS2 = AAM(IJTARG)
18157 PM1 = SIGN(PMASS1**2,PMASS1)
18158 PM2 = SIGN(PMASS2**2,PMASS2)
18159 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18161 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18162 & *(PINITA(4)+PINITA(5)))
18166 PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18168 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18169 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18173 PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18175 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18179 PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18181 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18186 *------- treatment of final state
18190 IF (NLOOP.GT.1) SCPOT = 0.10D0
18191 C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18203 DO 900 I=NPOINT(4),NHKK
18205 IF (ISTHKK(I).EQ.1) THEN
18206 IF (IDBAM(I).EQ.7) GOTO 900
18209 * particle moving into forward direction
18210 IF (PHKK(3,I).GE.ZERO) THEN
18211 * most likely to be effected by projectile potential
18213 * there is no projectile nucleus, try target
18214 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18216 IF (IP.GT.1) IOTHER = 1
18217 * there is no target nucleus --> skip
18218 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18220 * particle moving into backward direction
18222 * most likely to be effected by target potential
18224 * there is no target nucleus, try projectile
18225 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18227 IF (IT.GT.1) IOTHER = 1
18228 * there is no projectile nucleus --> skip
18229 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18233 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18234 * =1: particle is not in overlap-region AND is inside target (2)
18235 * =2: particle is not in overlap-region AND is inside projectile (1)
18236 * flag particles which are inside the nucleus ipot but not in its
18238 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18239 * baryons: keep all nucleons and all others where flag is set
18240 IF (IIBAR(IDBAM(I)).NE.0) THEN
18241 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18244 PMOMB(NOB) = PHKK(3,I)
18245 IDXB(NOB) = SIGN(1000000*IABS(IFLG)
18246 & +100000*IOTHER+I,IFLG)
18248 * mesons: keep only those mesons where flag is set
18250 IF (IFLG.GT.0) THEN
18252 PMOMM(NOM) = PHKK(3,I)
18253 IDXM(NOM) = 1000000*IFLG+100000*IOTHER+I
18259 * sort particles in the arrays according to increasing long. momentum
18260 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18261 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18263 * shuffle indices into one and the same array according to the later
18264 * sequence of correction
18268 IF (PMOMB(I).GT.ZERO) GOTO 911
18270 IDXCOR(NCOR) = IDXB(I)
18276 IF (PMOMB(I).LT.ZERO) GOTO 913
18278 IDXCOR(NCOR) = IDXB(I)
18283 IF (PMOMB(I).GT.ZERO) THEN
18285 IDXCOR(NCOR) = IDXB(I)
18293 IDXCOR(NCOR) = IDXB(I)
18297 IF (PMOMM(I).GT.ZERO) GOTO 926
18299 IDXCOR(NCOR) = IDXM(I)
18304 IF (PMOMM(I).LT.ZERO) GOTO 928
18306 IDXCOR(NCOR) = IDXM(I)
18310 C IF (NEVHKK.EQ.484) THEN
18311 C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18312 C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
18313 C WRITE(LOUT,9001) NOB,NOM,NCOR
18314 C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18315 C WRITE(LOUT,'(/,A)') ' baryons '
18317 CC J = IABS(IDXB(I))
18318 CC INDEX = J-IABS(J/1000000)*1000000
18319 C IPOT = IABS(IDXB(I))/1000000
18320 C IOTHER = IABS(IDXB(I))/100000-IPOT*10
18321 C INDEX = IABS(IDXB(I))-IPOT*1000000-IOTHER*100000
18322 C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18324 C WRITE(LOUT,'(/,A)') ' mesons '
18326 CC INDEX = IDXM(I)-IABS(IDXM(I)/1000000)*1000000
18327 C IPOT = IABS(IDXM(I))/1000000
18328 C IOTHER = IABS(IDXM(I))/100000-IPOT*10
18329 C INDEX = IABS(IDXM(I))-IPOT*1000000-IOTHER*100000
18330 C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18332 C 9002 FORMAT(1X,4I14,E14.5)
18333 C WRITE(LOUT,'(/,A)') ' all '
18335 CC J = IABS(IDXCOR(I))
18336 CC INDEX = J-IABS(J/1000000)*1000000
18337 CC IPOT = IABS(IDXCOR(I))/1000000
18338 C IOTHER = IABS(IDXCOR(I))/100000-IPOT*10
18339 C INDEX = IABS(IDXCOR(I))-IPOT*1000000-IOTHER*100000
18340 C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18342 C 9003 FORMAT(1X,4I14)
18346 IPOT = IABS(IDXCOR(ICOR))/1000000
18347 IOTHER = IABS(IDXCOR(ICOR))/100000-IPOT*10
18348 I = IABS(IDXCOR(ICOR))-IPOT*1000000-IOTHER*100000
18353 * reduction of particle momentum by corresponding nuclear potential
18354 * (this applies only if Fermi-momenta are requested)
18358 * Lorentz-transformation into the rest system of the selected nucleus
18360 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18361 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18362 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18363 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18367 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18368 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18369 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18370 IF (IOULEV(3).GT.0)
18371 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18372 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
18373 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18374 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
18382 * the correction for nuclear potential effects is applied to as many
18383 * p/n as many nucleons were wounded; the momenta of other final state
18384 * particles are corrected only if they materialize inside the corresp.
18385 * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18386 * = 3 part. outside proj. and targ., >=10 in overlapping region)
18387 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18388 IF (IPOT.EQ.1) THEN
18389 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18390 * this is most likely a wounded nucleon
18392 C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18393 C & +(VHKK(2,IPW(JPW))/FM2MM)**2
18394 C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
18395 C RAD = RNUCLE*DBLE(IP)**ONETHI
18396 C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18397 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18399 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18403 * correct only if part. was materialized inside nucleus
18404 * and if it is ouside the overlapping region
18405 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18406 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18410 ELSEIF (IPOT.EQ.2) THEN
18411 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18412 * this is most likely a wounded nucleon
18414 C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18415 C & +(VHKK(2,ITW(JTW))/FM2MM)**2
18416 C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
18417 C RAD = RNUCLE*DBLE(IT)**ONETHI
18418 C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18419 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18421 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18425 * correct only if part. was materialized inside nucleus
18426 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18427 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18433 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18434 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18439 IF (NLOOP.EQ.1) THEN
18440 * Coulomb energy correction:
18441 * the treatment of Coulomb potential correction is similar to the
18442 * one for nuclear potential
18443 IF (IDSEC.EQ.1) THEN
18444 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18446 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18449 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18452 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18454 IF (IICH(IDSEC).EQ.1) THEN
18455 * pos. particles: check if they are able to escape Coulomb potential
18456 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18457 ISTHKK(I) = 14+IPOT
18458 IF (ISTHKK(I).EQ.15) THEN
18460 PHKK(K,I) = PSEC0(K)
18461 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18463 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18464 IF (IDSEC.EQ.1) NPCW = NPCW-1
18465 ELSEIF (ISTHKK(I).EQ.16) THEN
18467 PHKK(K,I) = PSEC0(K)
18468 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18470 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18471 IF (IDSEC.EQ.1) NTCW = NTCW-1
18475 ELSEIF (IICH(IDSEC).EQ.-1) THEN
18476 * neg. particles: decrease energy by Coulomb-potential
18477 PSEC(4) = PSEC(4)-ETACOU(IPOT)
18484 IF (PSEC(4).LT.AMSEC) THEN
18485 IF (IOULEV(6).GT.0)
18486 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18487 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18488 & ' is not allowed to escape nucleus',/,
18489 & 8X,'id : ',I3,' reduced energy: ',E15.4,
18491 ISTHKK(I) = 14+IPOT
18492 IF (ISTHKK(I).EQ.15) THEN
18494 PHKK(K,I) = PSEC0(K)
18495 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18497 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18498 IF (IDSEC.EQ.1) NPCW = NPCW-1
18499 ELSEIF (ISTHKK(I).EQ.16) THEN
18501 PHKK(K,I) = PSEC0(K)
18502 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18504 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18505 IF (IDSEC.EQ.1) NTCW = NTCW-1
18510 IF (JPMOD.EQ.1) THEN
18511 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18512 * 4-momentum after correction for nuclear potential
18514 PSEC(K) = PSEC(K)*PSECN/PSECO
18517 * store recoil momentum from particles escaping the nuclear potentials
18519 IF (IPOT.EQ.1) THEN
18520 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18521 ELSEIF (IPOT.EQ.2) THEN
18522 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18526 * transform momentum back into n-n cms
18528 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18529 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18537 PFSP(K) = PFSP(K)+PHKK(K,I)
18542 DO 33 I=NPOINT(4),NHKK
18543 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18544 PFSP(1) = PFSP(1)+PHKK(1,I)
18545 PFSP(2) = PFSP(2)+PHKK(2,I)
18546 PFSP(3) = PFSP(3)+PHKK(3,I)
18547 PFSP(4) = PFSP(4)+PHKK(4,I)
18552 PRCLPR(K) = TRCLPR(K)
18553 PRCLTA(K) = TRCLTA(K)
18556 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18557 * hadron-nucleus interactions: get residual momentum from energy-
18558 * momentum conservation
18561 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18564 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18565 * accumulated recoil momenta of particles leaving the spectators
18566 * transform accumulated recoil momenta of residual nuclei into
18570 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18573 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18574 C IF (IP.GT.1) THEN
18575 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18576 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18579 PRCLTA(3) = PRCLTA(3)+PINITA(3)
18580 PRCLTA(4) = PRCLTA(4)+PINITA(4)
18584 * check momenta of residual nuclei
18586 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18588 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18590 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18592 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18594 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18595 **sr 19.12. changed to avoid output when used with phojet
18598 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18599 C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18600 C & CALL DT_EVTOUT(4)
18601 IF (IREJ1.GT.0) RETURN
18607 *===scn4ba=============================================================*
18609 CDECK ID>, DT_SCN4BA
18610 SUBROUTINE DT_SCN4BA
18612 ************************************************************************
18613 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
18614 * This version dated 12.12.95 is written by S. Roesler. *
18615 ************************************************************************
18617 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18620 PARAMETER ( LINP = 5 ,
18624 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18629 PARAMETER (NMXHKK=200000)
18631 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18632 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18633 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18634 * extended event history
18635 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18636 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18638 * particle properties (BAMJET index convention)
18640 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18641 & IICH(210),IIBAR(210),K1(210),K2(210)
18642 * properties of interacting particles
18643 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18644 * nuclear potential
18646 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18647 & EBINDP(2),EBINDN(2),EPOT(2,210),
18648 & ETACOU(2),ICOUL,LFERMI
18649 * treatment of residual nuclei: wounded nucleons
18650 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18651 * treatment of residual nuclei: 4-momenta
18652 LOGICAL LRCLPR,LRCLTA
18653 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18654 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18656 DIMENSION PLAB(2,5),PCMS(4)
18660 * get number of wounded nucleons
18677 * projectile nucleons wounded in primary interaction and in fzc
18678 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18682 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18683 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
18684 C IF (IP.GT.1) THEN
18686 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18689 * target nucleons wounded in primary interaction and in fzc
18690 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18694 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18695 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
18698 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18701 ELSEIF (ISTHKK(I).EQ.13) THEN
18703 ELSEIF (ISTHKK(I).EQ.14) THEN
18708 DO 11 I=NPOINT(4),NHKK
18709 * baryons which are unable to escape the nuclear potential of proj.
18710 IF (ISTHKK(I).EQ.15) THEN
18713 IF (IIBAR(IDBAM(I)).NE.0) THEN
18715 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18718 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18720 * baryons which are unable to escape the nuclear potential of targ.
18721 ELSEIF (ISTHKK(I).EQ.16) THEN
18724 IF (IIBAR(IDBAM(I)).NE.0) THEN
18726 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18729 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18734 * residual nuclei so far
18738 * ckeck for "residual nuclei" consisting of one nucleon only
18739 * treat it as final state particle
18740 IF (IRESP.EQ.1) THEN
18742 IST = ISTHKK(ISGLPR)
18743 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18744 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18745 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18746 IF (IST.EQ.13) THEN
18747 ISTHKK(ISGLPR) = 11
18751 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18752 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18753 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18754 NOBAM(NHKK) = NOBAM(ISGLPR)
18755 JDAHKK(1,ISGLPR) = NHKK
18757 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18760 IF (IREST.EQ.1) THEN
18762 IST = ISTHKK(ISGLTA)
18763 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18764 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18765 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18766 IF (IST.EQ.14) THEN
18767 ISTHKK(ISGLTA) = 12
18771 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18772 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18773 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18774 NOBAM(NHKK) = NOBAM(ISGLTA)
18775 JDAHKK(1,ISGLTA) = NHKK
18777 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18781 * get nuclear potential corresp. to the residual nucleus
18786 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18788 * baryons unable to escape the nuclear potential are treated as
18789 * excited nucleons (ISTHKK=15,16)
18790 DO 3 I=NPOINT(4),NHKK
18791 IF (ISTHKK(I).EQ.1) THEN
18793 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18794 * final state n and p not being outside of both nuclei are considered
18797 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
18798 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
18799 * Lorentz-trsf. into proj. rest sys. for those being inside proj.
18800 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18801 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18803 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18804 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18805 & (PLAB(1,4)+PLABT) ))
18806 EKIN = PLAB(1,4)-PLAB(1,5)
18807 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18808 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18810 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
18811 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
18812 * Lorentz-trsf. into targ. rest sys. for those being inside targ.
18813 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18814 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18816 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18817 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18818 & (PLAB(2,4)+PLABT) ))
18819 EKIN = PLAB(2,4)-PLAB(2,5)
18820 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18821 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18823 IF (PHKK(3,I).GE.ZERO) THEN
18825 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18828 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18830 IF (ISTHKK(I).NE.1) THEN
18833 PHKK(K,I) = PLAB(J,K)
18835 IF (ISTHKK(I).EQ.15) THEN
18837 IF (ID.EQ.1) NPCW = NPCW-1
18839 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18841 ELSEIF (ISTHKK(I).EQ.16) THEN
18843 IF (ID.EQ.1) NTCW = NTCW-1
18845 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18853 * again: get nuclear potential corresp. to the residual nucleus
18858 c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18859 cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18860 c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18862 c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18863 cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18864 c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18866 C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18867 C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18868 C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18869 C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18870 AFERP = FERMOD+0.1D0
18871 AFERT = FERMOD+0.1D0
18873 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18878 *===ficonf=============================================================*
18880 CDECK ID>, DT_FICONF
18881 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18883 ************************************************************************
18884 * Treatment of FInal CONFiguration including evaporation, fission and *
18885 * Fermi-break-up (for light nuclei only). *
18886 * Adopted from the original routine FINALE and extended to residual *
18887 * projectile nuclei. *
18888 * This version dated 12.12.95 is written by S. Roesler. *
18889 ************************************************************************
18891 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18894 PARAMETER ( LINP = 5 ,
18898 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18899 PARAMETER (ANGLGB=5.0D-16)
18903 PARAMETER (NMXHKK=200000)
18905 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18906 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18907 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18908 * extended event history
18909 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18910 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18912 * rejection counter
18913 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18914 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18915 & IREXCI(3),IRDIFF(2),IRINC
18916 * central particle production, impact parameter biasing
18917 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18918 * particle properties (BAMJET index convention)
18920 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18921 & IICH(210),IIBAR(210),K1(210),K2(210)
18922 * treatment of residual nuclei: 4-momenta
18923 LOGICAL LRCLPR,LRCLTA
18924 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18925 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18926 * treatment of residual nuclei: properties of residual nuclei
18927 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18928 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18929 & NTOTFI(2),NPROFI(2)
18930 * statistics: residual nuclei
18931 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18932 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18933 & NINCST(2,4),NINCEV(2),
18934 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18935 & NRESPB(2),NRESCH(2),NRESEV(4),
18936 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18938 * flags for input different options
18939 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18940 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18941 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18943 INCLUDE './flukapro/(DIMPAR)'
18944 INCLUDE './flukapro/(FINUC)'
18945 INCLUDE './flukapro/(RESNUC)'
18946 PARAMETER ( EMVGEV = 1.0 D-03 )
18947 PARAMETER ( AMUGEV = 0.93149432 D+00 )
18948 PARAMETER ( AMPRTN = 0.93827231 D+00 )
18949 PARAMETER ( AMNTRN = 0.93956563 D+00 )
18950 PARAMETER ( AMELCT = 0.51099906 D-03 )
18951 PARAMETER ( ELCCGS = 4.8032068 D-10 )
18952 PARAMETER ( ELCMKS = 1.60217733 D-19 )
18953 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
18955 PARAMETER ( HLFHLF = 0.5D+00 )
18956 PARAMETER ( FERTHO = 14.33 D-09 )
18957 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18958 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18959 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18960 INCLUDE './flukapro/(NUCDAT)'
18961 INCLUDE './flukapro/(PAREVT)'
18962 INCLUDE './flukapro/(FHEAVY)'
18965 COMMON /DTEVNO/ NEVENT,ICASCA
18967 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18968 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18969 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18971 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18972 DATA EXC,NEXC /520*ZERO,520*0/
18973 DATA EXPNUC /4.0D-3,4.0D-3/
18979 * skip residual nucleus treatment if not requested or in case
18980 * of central collisions
18981 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19008 * number of final state particles
19009 IF (ABS(ISTHKK(I)).EQ.1) THEN
19014 * properties of remaining nucleon configurations
19016 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19017 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19019 IF (MO1(KF).EQ.0) MO1(KF) = I
19021 * position of residual nucleus = average position of nucleons
19023 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19024 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19026 * total number of particles contributing to each residual nucleus
19027 NTOT(KF) = NTOT(KF)+1
19030 * total charge of residual nuclei
19031 NQ(KF) = NQ(KF)+IICH(IDTMP)
19032 * number of protons
19033 IF (IDHKK(I).EQ.2212) THEN
19034 NPRO(KF) = NPRO(KF)+1
19035 * number of neutrons
19036 ELSEIF (IDHKK(I).EQ.2112) THEN
19039 * number of baryons other than n, p
19040 IF (IIBAR(IDTMP).EQ.1) THEN
19042 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19044 * any other mesons (status set to 1)
19045 C WRITE(LOUT,1002) KF,IDTMP
19046 C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
19047 C & ' containing meson ',I4,', status set to 1')
19050 IDXTMP = IDXPAR(KF)
19051 NTOT(KF) = NTOT(KF)-1
19055 IDXPAR(KF) = IDXTMP
19059 * reject elastic events (def: one final state particle = projectile)
19060 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19061 IREXCI(3) = IREXCI(3)+1
19066 * check if one nucleus disappeared..
19067 C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19069 C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19072 C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19074 C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19083 * get the average of the nucleon positions
19084 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19085 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19086 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19087 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19089 * mass number and charge of residual nuclei
19090 AIF(I) = DBLE(NTOT(I))
19091 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
19092 IF (NTOT(I).GT.1) THEN
19093 * masses of residual nuclei in ground state
19095 C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
19096 AMRCL0(I) = AIF(I)*AMUC12
19097 & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
19099 * masses of residual nuclei
19100 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
19101 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
19102 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
19103 IF (AMRCL(I).LE.ZERO) THEN
19104 IF (IOULEV(3).GT.0)
19105 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
19107 1000 FORMAT(1X,'warning! negative excitation energy',/,
19111 IF (NLOOP.LE.500) THEN
19114 IREXCI(2) = IREXCI(2)+1
19117 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
19120 C WRITE(6,*) NEVHKK,I,NTOT(1),NTOT(2),AMRCL(I),AMRCL0(I)
19123 C AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
19124 M = MIN(NTOT(I),260)
19125 IF (NEXC(I,M).GT.0) THEN
19126 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19130 IF (M.GE.INUC(I)) THEN
19131 AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
19133 IF (NEXC(I,M).GT.0) THEN
19134 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19141 EEXC(I) = AMRCL(I)-AMRCL0(I)
19143 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19144 IF (IOULEV(3).GT.0)
19145 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19146 1004 FORMAT(1X,'warning! too high excitation energy',/,
19147 & I4,1P,2E15.4,3I5)
19150 IF (NLOOP.LE.500) THEN
19153 IREXCI(2) = IREXCI(2)+1
19157 * excitation energies of residual nuclei
19158 EEXC(I) = AMRCL(I)-AMRCL0(I)
19159 IF (ICASCA.EQ.0) THEN
19161 C EXPNUC(I) = EEXC(I)/DBLE(NTOT(I))
19162 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19163 M = MIN(NTOT(I),260)
19164 EXC(I,M) = EXC(I,M)+EEXC(I)
19165 NEXC(I,M) = NEXC(I,M)+1
19168 ELSEIF (NTOT(I).EQ.1) THEN
19170 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
19180 PRCLPR(5) = AMRCL(1)
19181 PRCLTA(5) = AMRCL(2)
19183 IF (ICOR.GT.0) THEN
19184 IF (INORCL.EQ.0) THEN
19185 * one or both residual nuclei consist of one nucleon only, transform
19186 * this nucleon on mass shell
19188 P1IN(K) = PRCL(1,K)
19189 P2IN(K) = PRCL(2,K)
19193 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19194 IF (IREJ1.GT.0) THEN
19195 WRITE(LOUT,*) 'ficonf-mashel rejection'
19199 PRCL(1,K) = P1OUT(K)
19200 PRCL(2,K) = P2OUT(K)
19201 PRCLPR(K) = P1OUT(K)
19202 PRCLTA(K) = P2OUT(K)
19204 PRCLPR(5) = AMRCL(1)
19205 PRCLTA(5) = AMRCL(2)
19207 IF (IOULEV(3).GT.0)
19208 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19209 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19210 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19211 & AMRCL(2),AMRCL(2)-AMRCL0(2)
19212 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
19213 & ' correction',/,11X,'at event',I8,
19214 & ', nucleon config. 1:',2I4,' 2:',2I4,
19216 IF (NLOOP.LE.500) THEN
19219 IREXCI(1) = IREXCI(1)+1
19225 C IF (NRESEV(1).NE.NEVHKK) THEN
19226 C NRESEV(1) = NEVHKK
19227 C NRESEV(2) = NRESEV(2)+1
19229 NRESEV(2) = NRESEV(2)+1
19231 EXCDPM(I) = EXCDPM(I)+EEXC(I)
19232 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19233 NRESTO(I) = NRESTO(I)+NTOT(I)
19234 NRESPR(I) = NRESPR(I)+NPRO(I)
19235 NRESNU(I) = NRESNU(I)+NN(I)
19236 NRESBA(I) = NRESBA(I)+NH(I)
19237 NRESPB(I) = NRESPB(I)+NHPOS(I)
19238 NRESCH(I) = NRESCH(I)+NQ(I)
19244 * initialize evaporation counter
19247 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19248 & (EEXC(I).GT.ZERO)) THEN
19249 * put residual nuclei into DTEVT1
19251 JMASS = INT( AIF(I))
19252 JCHAR = INT(AIZF(I))
19253 * the following patch is required to transmit the correct excitation
19255 IF (ITRSPT.EQ.1) THEN
19257 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19259 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19261 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19264 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19265 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19270 VHKK(J,NHKK) = VRCL(I,J)
19271 WHKK(J,NHKK) = WRCL(I,J)
19273 * interface to evaporation module - fill final residual nucleus into
19275 * fill resnuc only if code is not used as event generator in Fluka
19276 IF (ITRSPT.NE.1) THEN
19280 IBRES = NPRO(I)+NN(I)+NH(I)
19281 ICRES = NPRO(I)+NHPOS(I)
19284 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
19285 * ground state mass of the residual nucleus (should be equal to AM0T)
19288 AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
19292 * kinetic energy of residual nucleus
19293 TVRECL = PRCL(I,4)-AMRCL(I)
19294 * excitation energy of residual nucleus
19297 PTRES = SQRT(ABS(TVRECL*(TVRECL+
19298 & 2.0D0*(AMMRES+TVCMS))))
19299 IF (PTOLD.LT.ANGLGB) THEN
19300 CALL DT_RACO(PXRES,PYRES,PZRES)
19303 PXRES = PXRES*PTRES/PTOLD
19304 PYRES = PYRES*PTRES/PTOLD
19305 PZRES = PZRES*PTRES/PTOLD
19314 * put evaporated particles and residual nuclei to DTEVT1
19316 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19319 EXCEVA(I) = EXCEVA(I)+EXCITF
19326 C9998 IREXCI(1) = IREXCI(1)+1
19335 *====eva2he============================================================*
19337 CDECK ID>, DT_EVA2HE
19338 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19340 ************************************************************************
19341 * Interface between common's of evaporation module (FKFINU,FKFHVY) *
19343 * MO DTEVT1-index of "mother" (residual) nucleus before evap. *
19344 * EEXCF exitation energy of residual nucleus after evaporation *
19345 * IRCL = 1 projectile residual nucleus *
19346 * = 2 target residual nucleus *
19347 * This version dated 19.04.95 is written by S. Roesler. *
19348 ************************************************************************
19350 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19353 PARAMETER ( LINP = 5 ,
19357 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19361 PARAMETER (NMXHKK=200000)
19363 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19364 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19365 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19366 * Note: DTEVT2 - special use for heavy fragments !
19367 * (IDRES(I) = mass number, IDXRES(I) = charge)
19368 * extended event history
19369 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19370 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19372 * particle properties (BAMJET index convention)
19374 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19375 & IICH(210),IIBAR(210),K1(210),K2(210)
19376 * flags for input different options
19377 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19378 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19379 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19380 * statistics: residual nuclei
19381 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19382 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19383 & NINCST(2,4),NINCEV(2),
19384 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19385 & NRESPB(2),NRESCH(2),NRESEV(4),
19386 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19388 * treatment of residual nuclei: properties of residual nuclei
19389 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19390 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19391 & NTOTFI(2),NPROFI(2)
19393 INCLUDE './flukapro/(DIMPAR)'
19394 INCLUDE './flukapro/(FINUC)'
19395 INCLUDE './flukapro/(RESNUC)'
19396 INCLUDE './flukapro/(FHEAVY)'
19398 DIMENSION IPTOKP(39)
19399 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19400 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19401 & 100, 101, 97, 102, 98, 103, 109, 115 /
19405 * skip if evaporation package is not included
19406 IF (.NOT.LEVAPO) RETURN
19409 IF (NRESEV(3).NE.NEVHKK) THEN
19411 NRESEV(4) = NRESEV(4)+1
19415 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19417 * mass number/charge of residual nucleus before evaporation
19421 * protons/neutrons/gammas
19426 ID = IPTOKP(KPART(I))
19427 IDPDG = IDT_IPDGHA(ID)
19428 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19429 & (2.0D0*MAX(TKI(I),TINY10))
19430 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19431 WRITE(LOUT,1000) ID,AM,AAM(ID)
19432 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
19433 & 'particle',I3,2E10.3)
19436 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19438 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19439 IBTOT = IBTOT-IIBAR(ID)
19440 IZTOT = IZTOT-IICH(ID)
19445 PX = CXHEAV(I)*PHEAVY(I)
19446 PY = CYHEAV(I)*PHEAVY(I)
19447 PZ = CZHEAV(I)*PHEAVY(I)
19449 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19450 & (2.0D0*MAX(TKHEAV(I),TINY10))
19452 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19453 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19455 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19456 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19457 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19460 IF (IBRES.GT.0) THEN
19461 * residual nucleus after evaporation
19463 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19468 NTOTFI(IRCL) = IBRES
19469 NPROFI(IRCL) = ICRES
19470 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19471 IBTOT = IBTOT-IBRES
19472 IZTOT = IZTOT-ICRES
19474 * count events with fission
19475 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19476 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19478 * energy-momentum conservation check
19479 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19480 C IF (IREJ.GT.0) THEN
19481 C CALL DT_EVTOUT(4)
19482 C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19484 * baryon-number/charge conservation check
19485 IF (IBTOT+IZTOT.NE.0) THEN
19486 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19487 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
19488 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
19494 *===ebind==============================================================*
19496 CDECK ID>, DT_EBIND
19497 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19499 ************************************************************************
19500 * Binding energy for nuclei. *
19501 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
19503 * IZ atomic number *
19504 * This version dated 5.5.95 is updated by S. Roesler. *
19505 ************************************************************************
19507 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19510 PARAMETER ( LINP = 5 ,
19514 PARAMETER (ZERO=0.0D0)
19516 DATA A1, A2, A3, A4, A5
19517 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19519 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19520 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
19525 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19526 & -A4*(IA-2*IZ)**2/AA
19527 IF (MOD(IA,2).EQ.1) THEN
19529 ELSEIF (MOD(IZ,2).EQ.1) THEN
19534 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19539 ************************************************************************
19541 * DPMJET 3.0: cross section routines *
19543 ************************************************************************
19546 * SUBROUTINE DT_SHNDIF
19547 * diffractive cross sections (all energies)
19548 * SUBROUTINE DT_PHOXS
19549 * total and inel. cross sections from PHOJET interpol. tables
19550 * SUBROUTINE DT_XSHN
19551 * total and el. cross sections for all energies
19552 * SUBROUTINE DT_SIHNAB
19553 * pion 2-nucleon absorption cross sections
19554 * SUBROUTINE DT_SIGEMU
19555 * cross section for target "compounds"
19556 * SUBROUTINE DT_SIGGA
19557 * photon nucleus cross sections
19558 * SUBROUTINE DT_SIGGAT
19559 * photon nucleus cross sections from tables
19560 * SUBROUTINE DT_SANO
19561 * anomalous hard photon-nucleon cross sections from tables
19562 * SUBROUTINE DT_SIGGP
19563 * photon nucleon cross sections
19564 * SUBROUTINE DT_SIGVEL
19565 * quasi-elastic vector meson prod. cross sections
19566 * DOUBLE PRECISION FUNCTION DT_SIGVP
19568 * DOUBLE PRECISION FUNCTION DT_RRM2
19569 * DOUBLE PRECISION FUNCTION DT_RM2
19570 * DOUBLE PRECISION FUNCTION DT_SAM2
19571 * SUBROUTINE DT_CKMT
19572 * SUBROUTINE DT_CKMTX
19573 * SUBROUTINE DT_PDF0
19574 * SUBROUTINE DT_CKMTQ0
19575 * SUBROUTINE DT_CKMTDE
19576 * SUBROUTINE DT_CKMTPR
19577 * FUNCTION DT_CKMTFF
19579 * SUBROUTINE DT_FLUINI
19580 * total nucleon cross section fluctuation treatment
19582 * SUBROUTINE DT_SIGTBL
19583 * pre-tabulation of low-energy elastic x-sec. using SIHNEL
19584 * SUBROUTINE DT_XSTABL
19589 *===shndif===============================================================*
19591 CDECK ID>, DT_SHNDIF
19592 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
19594 **********************************************************************
19595 * Single diffractive hadron-nucleon cross sections *
19596 * S.Roesler 14/1/93 *
19598 * The cross sections are calculated from extrapolated single *
19599 * diffractive antiproton-proton cross sections (DTUJET92) using *
19600 * scaling relations between total and single diffractive cross *
19602 **********************************************************************
19604 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19606 PARAMETER (ZERO=0.0D0)
19608 * particle properties (BAMJET index convention)
19610 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19611 & IICH(210),IIBAR(210),K1(210),K2(210)
19613 CSD1 = 4.201483727D0
19614 CSD4 = -0.4763103556D-02
19615 CSD5 = 0.4324148297D0
19617 CHMSD1 = 0.8519297242D0
19618 CHMSD4 = -0.1443076599D-01
19619 CHMSD5 = 0.4014954567D0
19621 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
19622 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
19624 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
19625 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
19626 FRAC = SHMSD/SDIAPP
19628 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
19629 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
19630 & 10, 10, 20, 20, 20) KPROJ
19633 *---------------------------- p - p , n - p , sigma0+- - p ,
19635 CSD1 = 6.004476070D0
19636 CSD4 = -0.1257784606D-03
19637 CSD5 = 0.2447335720D0
19638 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
19639 SIGDIH = FRAC*SIGDIF
19646 C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
19648 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
19651 C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
19652 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
19654 SIGDIH = FRAC*SIGDIF
19658 *-------------------------- leptons..
19664 *===phoxs================================================================*
19666 CDECK ID>, DT_PHOXS
19667 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
19669 ************************************************************************
19670 * Total/inelastic proton-nucleon cross sections taken from PHOJET- *
19671 * interpolation tables. *
19672 * This version dated 05.11.97 is written by S. Roesler *
19673 ************************************************************************
19675 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19678 PARAMETER ( LINP = 5 ,
19682 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
19683 PARAMETER (TWOPI = 6.283185307179586454D+00,
19685 & GEV2MB = 0.38938D0)
19688 DATA LFIRST /.TRUE./
19690 * nucleon-nucleon event-generator
19693 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
19694 * particle properties (BAMJET index convention)
19696 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19697 & IICH(210),IIBAR(210),K1(210),K2(210)
19700 C PARAMETER (IEETAB=10)
19701 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
19703 C energy-interpolation table
19705 PARAMETER ( IEETA2 = 20 )
19707 DOUBLE PRECISION SIGTAB,SIGECM
19708 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
19711 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
19712 WRITE(LOUT,*) MCGENE
19713 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
19717 IF (ECM.LE.ZERO) THEN
19718 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
19719 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
19722 IF (MODE.EQ.1) THEN
19727 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
19729 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
19730 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
19736 IF(ECM.LE.SIGECM(IP,1)) THEN
19739 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
19741 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
19748 WRITE(LOUT,'(/1X,A,2E12.3)')
19749 & 'PHOXS: warning! energy above initialization limit (',
19750 & ECM,SIGECM(IP,ISIMAX)
19757 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
19758 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
19760 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
19761 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
19762 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
19763 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
19764 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
19770 *===xshn===============================================================*
19773 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
19775 ************************************************************************
19776 * Total and elastic hadron-nucleon cross section. *
19777 * Below 500GeV cross sections are based on the '98 data compilation *
19778 * of the PDG. At higher energies PHOJET results are used (patched to *
19779 * the low energy data at 500GeV). *
19780 * IP projectile index (BAMJET numbering scheme) *
19781 * (should be in the range 1..25) *
19782 * IT target index (BAMJET numbering scheme) *
19783 * (1 = proton, 8 = neutron) *
19784 * PL laboratory momentum *
19785 * ECM cm. energy (ignored if PL>0) *
19786 * STOT total cross section *
19787 * SELA elastic cross section *
19788 * Last change: 24.4.99 by S. Roesler *
19789 ************************************************************************
19791 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19794 PARAMETER ( LINP = 5 ,
19798 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
19800 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
19801 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
19802 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
19805 * particle properties (BAMJET index convention)
19807 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19808 & IICH(210),IIBAR(210),K1(210),K2(210)
19809 * nucleon-nucleon event-generator
19812 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
19814 C PARAMETER (IEETAB=10)
19815 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
19817 C energy-interpolation table
19819 PARAMETER ( IEETA2 = 20 )
19821 DOUBLE PRECISION SIGTAB,SIGECM
19822 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
19824 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
19825 DIMENSION IDXDAT(25,2)
19828 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
19829 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
19830 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
19831 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
19832 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
19833 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
19834 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
19836 * total cross sections:
19838 DATA (ASIGTO(1,K),K=1,NPOINT) /
19839 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
19840 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
19841 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
19842 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
19843 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
19844 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
19845 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
19847 DATA (ASIGTO(2,K),K=1,NPOINT) /
19848 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
19849 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
19850 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
19851 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
19852 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
19853 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
19854 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
19856 DATA (ASIGTO(3,K),K=1,NPOINT) /
19857 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
19858 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
19859 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
19860 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
19861 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
19862 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
19863 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
19865 DATA (ASIGTO(4,K),K=1,NPOINT) /
19866 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
19867 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
19868 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
19869 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
19870 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
19871 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
19872 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
19874 DATA (ASIGTO(5,K),K=1,NPOINT) /
19875 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
19876 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
19877 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
19878 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
19879 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
19880 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
19881 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
19883 DATA (ASIGTO(6,K),K=1,NPOINT) /
19884 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
19885 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
19886 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
19887 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
19888 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
19889 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
19890 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
19892 DATA (ASIGTO(7,K),K=1,NPOINT) /
19893 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
19894 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
19895 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
19896 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
19897 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
19898 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
19899 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
19901 DATA (ASIGTO(8,K),K=1,NPOINT) /
19902 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
19903 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
19904 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
19905 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
19906 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
19907 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
19908 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
19910 DATA (ASIGTO(9,K),K=1,NPOINT) /
19911 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
19912 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
19913 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
19914 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
19915 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
19916 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
19917 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
19919 DATA (ASIGTO(10,K),K=1,NPOINT) /
19920 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
19921 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
19922 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
19923 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
19924 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
19925 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
19926 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
19928 * elastic cross sections:
19930 DATA (ASIGEL(1,K),K=1,NPOINT) /
19931 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
19932 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
19933 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
19934 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
19935 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
19936 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
19937 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
19939 DATA (ASIGEL(2,K),K=1,NPOINT) /
19940 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
19941 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
19942 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
19943 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
19944 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
19945 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
19946 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
19948 DATA (ASIGEL(3,K),K=1,NPOINT) /
19949 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
19950 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
19951 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
19952 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
19953 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
19954 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
19955 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
19957 DATA (ASIGEL(4,K),K=1,NPOINT) /
19958 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
19959 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
19960 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
19961 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
19962 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
19963 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
19964 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
19966 DATA (ASIGEL(5,K),K=1,NPOINT) /
19967 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
19968 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
19969 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
19970 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
19971 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
19972 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
19973 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
19975 DATA (ASIGEL(6,K),K=1,NPOINT) /
19976 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
19977 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
19978 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
19979 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
19980 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
19981 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
19982 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
19984 DATA (ASIGEL(7,K),K=1,NPOINT) /
19985 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
19986 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
19987 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
19988 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
19989 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
19990 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
19991 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
19993 DATA (ASIGEL(8,K),K=1,NPOINT) /
19994 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
19995 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
19996 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
19997 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
19998 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
19999 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
20000 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
20002 DATA (ASIGEL(9,K),K=1,NPOINT) /
20003 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
20004 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
20005 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
20006 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
20007 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
20008 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
20009 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
20011 DATA (ASIGEL(10,K),K=1,NPOINT) /
20012 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
20013 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
20014 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
20015 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
20016 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
20017 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
20018 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
20020 DATA (IDXDAT(K,1),K=1,25) /
20021 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
20023 DATA (IDXDAT(K,2),K=1,25) /
20024 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
20027 DATA LFIRST /.TRUE./
20030 APLABL = LOG10(PLABLO)
20031 APLABH = LOG10(PLABHI)
20032 APTHRE = LOG10(PTHRE)
20033 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
20034 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
20037 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
20038 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
20039 IF (MCGENE.EQ.2) THEN
20040 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
20041 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
20043 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
20046 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
20048 PHOSEL = PHOSTO-PHOSIN
20049 APHOST = LOG10(PHOSTO)
20050 APHOSE = LOG10(PHOSEL)
20057 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
20058 WRITE(LOUT,1000) IP,IT
20059 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
20060 & 'proj/target',2I4)
20064 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
20065 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
20066 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
20067 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
20068 WRITE(LOUT,1001) PLAB,ECMS
20069 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
20073 * index of spectrum
20076 IF (AAM(IP).GT.ZERO) THEN
20077 IF (ABS(IIBAR(IP)).GT.0) THEN
20087 IF (IT.EQ.8) IDXT = 2
20088 IDXS = IDXDAT(IDXP,IDXT)
20089 IF (IDXS.EQ.0) RETURN
20091 * compute momentum bin indices
20092 IF (PLAB.LT.PLABLO) THEN
20095 ELSEIF (PLAB.GE.PLABHI) THEN
20099 APLAB = LOG10(PLAB)
20100 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
20101 IDX0 = INT((APLAB-APLABL)/ADP1)+1
20102 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
20103 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
20108 * interpolate cross section
20109 IF (IDXS.GT.10) THEN
20111 IDXS2 = IDXS-10*IDXS1
20112 IF (IDX0.EQ.IDX1) THEN
20113 IF (IDX0.EQ.1) THEN
20114 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
20115 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
20118 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
20119 PHOSEL = PHOSTO-PHOSIN
20120 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
20121 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
20122 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
20123 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
20124 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
20125 ASELA = 0.5D0*(ASELA1+ASELA2)
20128 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
20129 ASTOT1 = ASIGTO(IDXS1,IDX0)+
20130 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
20131 ASTOT2 = ASIGTO(IDXS2,IDX0)+
20132 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
20133 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
20134 ASELA1 = ASIGEL(IDXS1,IDX0)+
20135 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
20136 ASELA2 = ASIGEL(IDXS2,IDX0)+
20137 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
20138 ASELA = 0.5D0*(ASELA1+ASELA2)
20141 IF (IDX0.EQ.IDX1) THEN
20142 IF (IDX0.EQ.1) THEN
20143 ASTOT = ASIGTO(IDXS,IDX0)
20144 ASELA = ASIGEL(IDXS,IDX0)
20147 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
20148 PHOSEL = PHOSTO-PHOSIN
20149 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
20150 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
20153 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
20154 ASTOT = ASIGTO(IDXS,IDX0)+
20155 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
20156 ASELA = ASIGEL(IDXS,IDX0)+
20157 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
20160 STOT = 10.0D0**ASTOT
20161 SELA = 10.0D0**ASELA
20166 *===sihnab===============================================================*
20168 CDECK ID>, DT_SIHNAB
20169 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
20171 **********************************************************************
20172 * Pion 2-nucleon absorption cross sections. *
20173 * (sigma_tot for pi+ d --> p p, pi- d --> n n *
20174 * taken from Ritchie PRC 28 (1983) 926 ) *
20175 * This version dated 18.05.96 is written by S. Roesler *
20176 **********************************************************************
20178 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20180 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
20181 PARAMETER (AMPR = 938.0D0,
20191 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
20192 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
20194 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
20195 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
20196 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
20197 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
20198 * approximate 3N-abs., I=1-abs. etc.
20199 SIGABS = SIGABS/0.40D0
20200 * pi0-absorption (rough approximation!!)
20201 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
20206 *===sigemu=============================================================*
20208 CDECK ID>, DT_SIGEMU
20209 SUBROUTINE DT_SIGEMU
20211 ************************************************************************
20212 * Combined cross section for target compounds. *
20213 * This version dated 6.4.98 is written by S. Roesler *
20214 ************************************************************************
20216 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20219 PARAMETER ( LINP = 5 ,
20223 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
20224 & OHALF=0.5D0,ONE=1.0D0)
20226 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20228 * Glauber formalism: cross sections
20229 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
20230 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
20231 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
20232 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
20233 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
20234 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
20235 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
20236 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
20237 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
20238 & BSLOPE,NEBINI,NQBINI
20239 * emulsion treatment
20240 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
20242 * nucleon-nucleon event-generator
20245 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20247 IF (MCGENE.NE.4) THEN
20248 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
20249 WRITE(LOUT,'(15X,A)') '-----------------------'
20269 IF (NCOMPO.GT.0) THEN
20271 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
20272 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
20273 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
20274 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
20275 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
20276 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
20277 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
20278 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
20279 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
20280 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
20281 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
20282 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
20283 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
20284 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
20285 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
20286 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
20288 ERRTOT = SQRT(ERRTOT)
20289 ERRELA = SQRT(ERRELA)
20290 ERRQEP = SQRT(ERRQEP)
20291 ERRQET = SQRT(ERRQET)
20292 ERRQE2 = SQRT(ERRQE2)
20293 ERRPRO = SQRT(ERRPRO)
20294 ERRDEL = SQRT(ERRDEL)
20295 ERRDQE = SQRT(ERRDQE)
20297 SIGTOT = XSTOT(IE,IQ,1)
20298 SIGELA = XSELA(IE,IQ,1)
20299 SIGQEP = XSQEP(IE,IQ,1)
20300 SIGQET = XSQET(IE,IQ,1)
20301 SIGQE2 = XSQE2(IE,IQ,1)
20302 SIGPRO = XSPRO(IE,IQ,1)
20303 SIGDEL = XSDEL(IE,IQ,1)
20304 SIGDQE = XSDQE(IE,IQ,1)
20305 ERRTOT = XETOT(IE,IQ,1)
20306 ERRELA = XEELA(IE,IQ,1)
20307 ERRQEP = XEQEP(IE,IQ,1)
20308 ERRQET = XEQET(IE,IQ,1)
20309 ERRQE2 = XEQE2(IE,IQ,1)
20310 ERRPRO = XEPRO(IE,IQ,1)
20311 ERRDEL = XEDEL(IE,IQ,1)
20312 ERRDQE = XEDQE(IE,IQ,1)
20314 IF (MCGENE.NE.4) THEN
20315 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
20316 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
20317 WRITE(LOUT,1001) SIGTOT,ERRTOT
20318 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
20319 WRITE(LOUT,1002) SIGELA,ERRELA
20320 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
20321 WRITE(LOUT,1003) SIGQEP,ERRQEP
20322 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
20324 WRITE(LOUT,1004) SIGQET,ERRQET
20325 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
20327 WRITE(LOUT,1005) SIGQE2,ERRQE2
20328 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
20329 & ' +-',F11.5,' mb')
20330 WRITE(LOUT,1006) SIGPRO,ERRPRO
20331 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
20332 WRITE(LOUT,1007) SIGDEL,ERRDEL
20333 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
20334 WRITE(LOUT,1008) SIGDQE,ERRDQE
20335 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
20344 *===sigga==============================================================*
20346 CDECK ID>, DT_SIGGA
20347 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
20349 ************************************************************************
20350 * Total/inelastic photon-nucleus cross sections. *
20351 * !!!! Overwrites SHMAKI-initialization. Do not use it during *
20352 * production runs !!!! *
20353 * This version dated 27.03.96 is written by S. Roesler *
20354 ************************************************************************
20356 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20359 PARAMETER ( LINP = 5 ,
20363 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
20364 & OHALF=0.5D0,ONE=1.0D0)
20365 PARAMETER (AMPROT = 0.938D0)
20367 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20369 * Glauber formalism: cross sections
20370 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
20371 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
20372 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
20373 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
20374 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
20375 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
20376 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
20377 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
20378 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
20379 & BSLOPE,NEBINI,NQBINI
20386 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20387 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
20388 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
20389 STOT = XSTOT(1,1,1)
20390 ETOT = XETOT(1,1,1)
20397 *===siggat=============================================================*
20399 CDECK ID>, DT_SIGGAT
20400 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
20402 ************************************************************************
20403 * Total/inelastic photon-nucleus cross sections. *
20404 * Uses pre-tabulated cross section. *
20405 * This version dated 29.07.96 is written by S. Roesler *
20406 ************************************************************************
20408 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20411 PARAMETER ( LINP = 5 ,
20415 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
20416 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20418 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20420 * Glauber formalism: cross sections
20421 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
20422 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
20423 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
20424 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
20425 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
20426 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
20427 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
20428 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
20429 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
20430 & BSLOPE,NEBINI,NQBINI
20436 IF (NEBINI.GT.1) THEN
20437 IF (ECMI.GE.ECMNN(NEBINI)) THEN
20441 ELSEIF (ECMI.GT.ECMNN(1)) THEN
20443 IF (ECMI.LT.ECMNN(I)) THEN
20446 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
20456 IF (NQBINI.GT.1) THEN
20457 IF (Q2I.GE.Q2G(NQBINI)) THEN
20461 ELSEIF (Q2I.GT.Q2G(1)) THEN
20463 IF (Q2I.LT.Q2G(I)) THEN
20466 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
20467 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
20468 C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
20476 STOT = XSTOT(I1,J1,NTARG)+
20477 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
20478 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
20479 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
20480 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
20485 *===sigano=============================================================*
20488 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
20490 ************************************************************************
20491 * This version dated 31.07.96 is written by S. Roesler *
20492 ************************************************************************
20494 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20497 PARAMETER ( LINP = 5 ,
20501 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
20502 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20505 * VDM parameter for photon-nucleus interactions
20506 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20507 * properties of interacting particles
20508 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
20510 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
20512 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
20513 & 0.100D+04,0.200D+04,0.500D+04
20515 * fixed cut (3 GeV/c)
20517 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
20518 & 0.062D+00,0.054D+00,0.042D+00
20521 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
20522 & 3.3086D-01,7.6255D-01,2.1319D+00
20524 * running cut (based on obsolete Phojet-caluclations, bugs..)
20526 C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
20527 C & 0.167E+00,0.150E+00,0.131E+00
20530 C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
20531 C & 2.5736E-01,4.5593E-01,8.2550E-01
20535 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
20539 IF (ECM.GE.ECMANO(NE)) THEN
20542 ELSEIF (ECM.GT.ECMANO(1)) THEN
20544 IF (ECM.LT.ECMANO(IE)) THEN
20547 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
20553 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
20554 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
20555 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
20556 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
20562 *===siggp==============================================================*
20564 CDECK ID>, DT_SIGGP
20565 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
20567 ************************************************************************
20568 * Total/inelastic photon-nucleon cross sections. *
20569 * This version dated 30.04.96 is written by S. Roesler *
20570 ************************************************************************
20572 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20575 PARAMETER ( LINP = 5 ,
20579 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20580 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20582 & GEV2MB = 0.38938D0,
20583 & ALPHEM = ONE/137.0D0)
20585 * particle properties (BAMJET index convention)
20587 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20588 & IICH(210),IIBAR(210),K1(210),K2(210)
20589 * VDM parameter for photon-nucleus interactions
20590 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20593 C CHARACTER*8 MDLNA
20594 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
20595 C PARAMETER (IEETAB=10)
20596 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20598 C model switches and parameters
20600 INTEGER ISWMDL,IPAMDL
20601 DOUBLE PRECISION PARMDL
20602 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20603 C energy-interpolation table
20605 PARAMETER ( IEETA2 = 20 )
20607 DOUBLE PRECISION SIGTAB,SIGECM
20608 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20611 C PARAMETER (NPOINT=80)
20612 PARAMETER (NPOINT=16)
20613 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
20620 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20621 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
20625 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20627 X = Q2/(W2+Q2-AAM(1)**2)
20629 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
20630 X = Q2/(W2+Q2-AAM(1)**2)
20631 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20632 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
20633 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
20634 W2 = Q2*(ONE-X)/X+AAM(1)**2
20636 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
20641 IF (MODEGA.EQ.1) THEN
20643 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
20647 C ALLMF2 = PHO_ALLM97(Q2,W)
20649 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
20650 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
20653 ELSEIF (MODEGA.EQ.2) THEN
20654 IF (INTRGE(1).EQ.1) THEN
20655 AMLO2 = (3.0D0*AAM(13))**2
20656 ELSEIF (INTRGE(1).EQ.2) THEN
20661 IF (INTRGE(2).EQ.1) THEN
20663 ELSEIF (INTRGE(2).EQ.2) THEN
20668 AMHI20 = (ECM-AAM(1))**2
20669 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
20670 XAMLO = LOG( AMLO2+Q2 )
20671 XAMHI = LOG( AMHI2+Q2 )
20673 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
20676 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
20681 AM2 = EXP(ABSZX(J))-Q2
20682 IF (AM2.LT.16.0D0) THEN
20684 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
20689 C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
20690 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
20691 & * (ONE+EPSPOL*Q2/AM2)
20692 SUM = SUM+WEIGHT(J)*FAC
20695 SDIR = DT_SIGVP(X,Q2)
20696 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
20697 SDIR = SDIR/(0.588D0+RL2+Q2)
20698 C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
20699 ELSEIF (MODEGA.EQ.3) THEN
20700 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
20701 ELSEIF (MODEGA.EQ.4) THEN
20702 * load cross sections from PHOJET interpolation table
20704 IF(ECM.LE.SIGECM(IP,1)) THEN
20707 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20709 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
20715 WRITE(LOUT,'(/1X,A,2E12.3)')
20716 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
20721 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20722 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20724 * cross section dependence on photon virtuality
20727 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
20728 & /(1.D0+Q2/PARMDL(30+I))**2
20730 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
20734 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20735 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20736 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
20740 SDIR = SDIR/(FSUP1*FSUP2)
20749 *===sigvel=============================================================*
20751 CDECK ID>, DT_SIGVEL
20752 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
20754 ************************************************************************
20755 * Cross section for elastic vector meson production *
20756 * This version dated 10.05.96 is written by S. Roesler *
20757 ************************************************************************
20759 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20762 PARAMETER ( LINP = 5 ,
20766 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20767 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20769 & GEV2MB = 0.38938D0,
20770 & ALPHEM = ONE/137.0D0)
20772 * particle properties (BAMJET index convention)
20774 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20775 & IICH(210),IIBAR(210),K1(210),K2(210)
20776 * VDM parameter for photon-nucleus interactions
20777 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20780 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20781 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
20785 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20787 X = Q2/(W2+Q2-AAM(1)**2)
20789 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
20790 X = Q2/(W2+Q2-AAM(1)**2)
20791 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20792 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
20793 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
20794 W2 = Q2*(ONE-X)/X+AAM(1)**2
20796 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
20804 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
20805 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
20807 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
20808 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
20810 IF (IDXV.EQ.33) THEN
20815 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
20817 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
20818 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
20823 *===sigvp==============================================================*
20825 CDECK ID>, DT_SIGVP
20826 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
20828 ************************************************************************
20830 ************************************************************************
20832 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20835 PARAMETER ( LINP = 5 ,
20839 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20840 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20842 & GEV2MB = 0.38938D0,
20843 & AMPROT = 0.938D0,
20844 & ALPHEM = ONE/137.0D0)
20845 * VDM parameter for photon-nucleus interactions
20846 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20850 IF (XI.LE.ZERO) X = 0.0001D0
20851 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
20853 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
20856 IF (MODEGA.EQ.1) THEN
20857 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
20861 C ALLMF2 = PHO_ALLM97(Q2,W)
20863 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
20864 C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
20865 C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
20866 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
20867 ELSEIF (MODEGA.EQ.4) THEN
20868 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
20869 C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
20870 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
20872 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
20879 *===RRM2===============================================================*
20882 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
20884 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20887 PARAMETER ( LINP = 5 ,
20891 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20892 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20894 & GEV2MB = 0.38938D0)
20896 * particle properties (BAMJET index convention)
20898 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20899 & IICH(210),IIBAR(210),K1(210),K2(210)
20900 * VDM parameter for photon-nucleus interactions
20901 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20903 S = Q2*(ONE-X)/X+AAM(1)**2
20906 IF (INTRGE(1).EQ.1) THEN
20907 AMLO2 = (3.0D0*AAM(13))**2
20908 ELSEIF (INTRGE(1).EQ.2) THEN
20913 IF (INTRGE(2).EQ.1) THEN
20915 ELSEIF (INTRGE(2).EQ.2) THEN
20920 AMHI20 = (ECM-AAM(1))**2
20921 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
20925 IF (AMHI2.LE.AM1C2) THEN
20926 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
20927 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
20928 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
20929 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
20931 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
20932 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
20933 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
20939 *===RM2================================================================*
20942 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
20944 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20947 PARAMETER ( LINP = 5 ,
20951 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20952 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20954 & GEV2MB = 0.38938D0)
20955 * VDM parameter for photon-nucleus interactions
20956 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20958 IF (RL2.LE.ZERO) THEN
20959 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
20960 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
20961 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
20963 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
20964 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
20965 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
20966 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
20968 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
20969 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
20975 *===SAM2===============================================================*
20978 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
20980 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20983 PARAMETER ( LINP = 5 ,
20987 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
20988 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
20989 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20991 & GEV2MB = 0.38938D0)
20993 * particle properties (BAMJET index convention)
20995 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20996 & IICH(210),IIBAR(210),K1(210),K2(210)
20997 * VDM parameter for photon-nucleus interactions
20998 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21001 IF (INTRGE(1).EQ.1) THEN
21002 AMLO2 = (3.0D0*AAM(13))**2
21003 ELSEIF (INTRGE(1).EQ.2) THEN
21008 IF (INTRGE(2).EQ.1) THEN
21010 ELSEIF (INTRGE(2).EQ.2) THEN
21015 AMHI20 = (ECM-AAM(1))**2
21016 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21020 YLO = LOG(AMLO2+Q2)
21021 YC1 = LOG(AM1C2+Q2)
21022 YC2 = LOG(AM2C2+Q2)
21023 YHI = LOG(AMHI2+Q2)
21024 IF (AMHI2.LE.AM1C2) THEN
21026 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
21033 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
21034 IF (YSAM2.LE.YC1) THEN
21036 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
21041 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
21042 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
21043 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
21045 DT_SAM2 = EXP(YSAM2)-Q2
21050 *===ckmt===============================================================*
21053 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
21056 ************************************************************************
21057 * This version dated 31.01.96 is written by S. Roesler *
21058 ************************************************************************
21060 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21063 PARAMETER ( LINP = 5 ,
21067 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
21069 PARAMETER (Q02 = 2.0D0,
21073 DIMENSION PD(-6:6),SEA(3),VAL(2)
21075 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
21076 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
21077 ADQ2 = LOG10(Q12)-LOG10(Q02)
21078 F2P = (F2Q1-F2Q0)/ADQ2
21079 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
21080 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
21081 F2PP = (F2PQ1-F2PQ0)/ADQ2
21082 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
21084 Q2 = MAX(SCALE**2.0D0,TINY10)
21085 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
21086 IF (Q2.LT.Q02) THEN
21087 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
21098 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
21111 C USEA = USEA*SMOOTH
21112 C DSEA = DSEA*SMOOTH
21121 CDECK ID>, DT_CKMTX
21122 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
21123 C**********************************************************************
21125 C PDF based on Regge theory, evolved with .... by ....
21127 C input: IPAR 2212 proton (not installed)
21131 C output: PD(-6:6) x*f(x) parton distribution functions
21132 C (PDFLIB convention: d = PD(1), u = PD(2) )
21134 C**********************************************************************
21137 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
21139 PARAMETER ( LINP = 5 ,
21148 C QCD lambda for evolution
21151 C Q0**2 for evolution
21155 C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
21156 C q(6)=x*charm, q(7)=x*gluon
21160 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
21162 IF(IPAR.EQ.2212) THEN
21163 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
21164 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
21165 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
21166 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
21167 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
21168 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
21169 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
21170 C ELSEIF (IPAR.EQ.45) THEN
21171 C CALL CKMTPO(1,0,XX,SB,QQ(1))
21172 C CALL CKMTPO(2,0,XX,SB,QQ(2))
21173 C CALL CKMTPO(3,0,XX,SB,QQ(3))
21174 C CALL CKMTPO(4,0,XX,SB,QQ(4))
21175 C CALL CKMTPO(5,0,XX,SB,QQ(5))
21176 C CALL CKMTPO(8,0,XX,SB,QQ(6))
21177 C CALL CKMTPO(7,0,XX,SB,QQ(7))
21178 ELSEIF (IPAR.EQ.100) THEN
21179 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
21180 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
21181 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
21182 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
21183 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
21184 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
21185 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
21187 WRITE(LOUT,'(1X,A,I4,A)')
21188 & 'CKMTX: IPAR =',IPAR,' not implemented!'
21194 PD(-4) = DBLE(QQ(6))
21195 PD(-3) = DBLE(QQ(3))
21196 PD(-2) = DBLE(QQ(4))
21197 PD(-1) = DBLE(QQ(5))
21198 PD(0) = DBLE(QQ(7))
21199 PD(1) = DBLE(QQ(2))
21200 PD(2) = DBLE(QQ(1))
21201 PD(3) = DBLE(QQ(3))
21202 PD(4) = DBLE(QQ(6))
21205 IF(IPAR.EQ.45) THEN
21206 CDN = (PD(1)-PD(-1))/2.D0
21207 CUP = (PD(2)-PD(-2))/2.D0
21208 PD(-1) = PD(-1) + CDN
21209 PD(-2) = PD(-2) + CUP
21213 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
21214 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
21215 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
21219 *===pdf0===============================================================*
21222 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
21224 ************************************************************************
21225 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
21226 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
21227 * IPAR = 2212 proton *
21229 * This version dated 31.01.96 is written by S. Roesler *
21230 ************************************************************************
21232 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21235 PARAMETER ( LINP = 5 ,
21239 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
21248 & DELTA0 = 0.07684D0,
21253 & ALPHAR = 0.415D0,
21257 PARAMETER (NPOINT=16)
21258 C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21259 DIMENSION SEA(3),VAL(2)
21261 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
21262 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
21264 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
21265 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
21266 SEA(1) = 0.75D0*SEA0
21269 VAL(1) = 9.0D0/4.0D0*VALU0
21270 VAL(2) = 9.0D0*VALD0
21271 GLU0 = SEA(1)/(1.0D0-X)
21272 F2 = SEA0+VALU0+VALD0
21273 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
21274 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
21275 & 1.0D0/9.0D0*(2.0D0*SEA(3))
21276 IF (ABS(F2-F2PDF).GT.TINY9) THEN
21277 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
21281 C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
21284 C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
21290 C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
21291 C VALU0 = 9.0D0/4.0D0*VALU0
21292 C VALD0 = 9.0D0*VALD0
21293 C SEA0 = 0.75D0*SEA0
21294 C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
21295 C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
21297 C GLU = GLU0*(1.0D0-SUMQ)/SUMG
21299 WRITE(LOUT,'(1X,A,I4,A)')
21300 & 'PDF0: IPAR =',IPAR,' not implemented!'
21307 *===ckmtq0=============================================================*
21309 CDECK ID>, DT_CKMTQ0
21310 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
21312 ************************************************************************
21313 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
21314 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
21315 * IPAR = 2212 proton *
21317 * This version dated 31.01.96 is written by S. Roesler *
21318 ************************************************************************
21320 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21323 PARAMETER ( LINP = 5 ,
21327 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
21336 & DELTA0 = 0.07684D0,
21341 & ALPHAR = 0.415D0,
21345 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
21346 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
21348 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
21349 IF (IPAR.EQ.2212) THEN
21356 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
21357 & (Q2/(Q2+A))**(1.0D0+DELTA)
21358 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
21359 & (Q2/(Q2+B))**(ALPHAR)
21360 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
21361 & (Q2/(Q2+B))**(ALPHAR)
21363 WRITE(LOUT,'(1X,A,I4,A)')
21364 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
21371 CDECK ID>, DT_CKMTDE
21372 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
21374 C**********************************************************************
21376 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
21378 C This version by S. Roesler, 30.01.96
21379 C**********************************************************************
21382 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
21383 EQUIVALENCE (GF(1,1,1),DL(1))
21386 DATA (DL(K),K= 1, 85) /
21387 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
21388 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
21389 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
21390 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
21391 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
21392 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
21393 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
21394 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
21395 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
21396 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
21397 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
21398 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
21399 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
21400 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
21401 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
21402 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
21403 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
21404 DATA (DL(K),K= 86, 170) /
21405 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
21406 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
21407 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
21408 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
21409 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
21410 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
21411 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
21412 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21413 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21414 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21415 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21416 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21417 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21418 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21419 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21420 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
21421 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
21422 DATA (DL(K),K= 171, 255) /
21423 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
21424 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
21425 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
21426 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
21427 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
21428 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
21429 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
21430 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
21431 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
21432 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
21433 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
21434 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
21435 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
21436 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
21437 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
21438 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
21439 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
21440 DATA (DL(K),K= 256, 340) /
21441 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
21442 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
21443 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
21444 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
21445 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
21446 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21447 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21448 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21449 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21450 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21451 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21452 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21453 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21454 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
21455 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
21456 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
21457 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
21458 DATA (DL(K),K= 341, 425) /
21459 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
21460 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
21461 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
21462 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
21463 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
21464 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
21465 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
21466 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
21467 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
21468 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
21469 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
21470 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
21471 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
21472 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
21473 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
21474 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
21475 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
21476 DATA (DL(K),K= 426, 510) /
21477 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
21478 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
21479 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
21480 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21481 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21482 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21483 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21484 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21485 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21486 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21487 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21488 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
21489 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
21490 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
21491 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
21492 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
21493 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
21494 DATA (DL(K),K= 511, 595) /
21495 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
21496 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
21497 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
21498 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
21499 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
21500 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
21501 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
21502 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
21503 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
21504 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
21505 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
21506 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
21507 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
21508 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
21509 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
21510 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
21511 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
21512 DATA (DL(K),K= 596, 680) /
21513 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
21514 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21515 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21516 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21517 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21518 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21519 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21520 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21521 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21522 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
21523 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
21524 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
21525 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
21526 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
21527 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
21528 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
21529 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
21530 DATA (DL(K),K= 681, 765) /
21531 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
21532 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
21533 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
21534 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
21535 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
21536 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
21537 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
21538 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
21539 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
21540 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
21541 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
21542 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
21543 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
21544 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
21545 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
21546 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
21547 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21548 DATA (DL(K),K= 766, 850) /
21549 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21550 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21551 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21552 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21553 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21554 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21555 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21556 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
21557 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
21558 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
21559 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
21560 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
21561 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
21562 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
21563 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
21564 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
21565 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
21566 DATA (DL(K),K= 851, 935) /
21567 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
21568 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
21569 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
21570 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
21571 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
21572 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
21573 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
21574 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
21575 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
21576 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
21577 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
21578 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
21579 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
21580 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
21581 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21582 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21583 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21584 DATA (DL(K),K= 936, 1020) /
21585 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21586 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21587 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21588 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21589 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21590 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
21591 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
21592 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
21593 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
21594 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
21595 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
21596 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
21597 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
21598 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
21599 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
21600 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
21601 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
21602 DATA (DL(K),K= 1021, 1105) /
21603 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
21604 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
21605 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
21606 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
21607 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
21608 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
21609 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
21610 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
21611 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
21612 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
21613 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
21614 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
21615 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21616 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21617 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21618 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21619 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21620 DATA (DL(K),K= 1106, 1190) /
21621 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21622 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21623 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21624 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
21625 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
21626 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
21627 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
21628 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
21629 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
21630 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
21631 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
21632 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
21633 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
21634 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
21635 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
21636 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
21637 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
21638 DATA (DL(K),K= 1191, 1275) /
21639 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
21640 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
21641 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
21642 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
21643 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
21644 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
21645 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
21646 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
21647 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
21648 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
21649 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21650 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21651 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21652 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21653 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21654 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21655 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21656 DATA (DL(K),K= 1276, 1360) /
21657 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21658 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
21659 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
21660 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
21661 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
21662 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
21663 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
21664 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
21665 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
21666 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
21667 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
21668 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
21669 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
21670 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
21671 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
21672 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
21673 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
21674 DATA (DL(K),K= 1361, 1445) /
21675 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
21676 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
21677 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
21678 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
21679 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
21680 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
21681 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
21682 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
21683 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21684 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21685 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21686 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21687 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21688 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21689 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21690 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21691 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
21692 DATA (DL(K),K= 1446, 1530) /
21693 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
21694 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
21695 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
21696 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
21697 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
21698 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
21699 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
21700 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
21701 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
21702 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
21703 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
21704 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
21705 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
21706 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
21707 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
21708 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
21709 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
21710 DATA (DL(K),K= 1531, 1615) /
21711 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
21712 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
21713 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
21714 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
21715 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
21716 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
21717 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21718 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21719 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21720 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21721 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21722 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21723 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21724 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21725 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
21726 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
21727 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
21728 DATA (DL(K),K= 1616, 1700) /
21729 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
21730 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
21731 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
21732 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
21733 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
21734 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
21735 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
21736 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
21737 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
21738 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
21739 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
21740 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
21741 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
21742 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
21743 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
21744 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
21745 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
21746 DATA (DL(K),K= 1701, 1785) /
21747 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
21748 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
21749 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
21750 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
21751 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21752 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21753 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21754 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21755 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21756 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21757 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21758 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21759 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
21760 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
21761 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
21762 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
21763 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
21764 DATA (DL(K),K= 1786, 1870) /
21765 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
21766 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
21767 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
21768 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
21769 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
21770 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
21771 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
21772 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
21773 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
21774 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
21775 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
21776 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
21777 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
21778 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
21779 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
21780 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
21781 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
21782 DATA (DL(K),K= 1871, 1955) /
21783 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
21784 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
21785 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21786 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21787 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21788 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21789 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21790 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21791 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21792 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21793 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
21794 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
21795 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
21796 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
21797 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
21798 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
21799 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
21800 DATA (DL(K),K= 1956, 2040) /
21801 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
21802 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
21803 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
21804 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
21805 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
21806 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
21807 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
21808 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
21809 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
21810 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
21811 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
21812 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
21813 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
21814 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
21815 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
21816 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
21817 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
21818 DATA (DL(K),K= 2041, 2125) /
21819 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21820 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21821 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21822 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21823 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21824 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21825 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21826 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21827 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
21828 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
21829 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
21830 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
21831 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
21832 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
21833 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
21834 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
21835 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
21836 DATA (DL(K),K= 2126, 2210) /
21837 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
21838 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
21839 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
21840 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
21841 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
21842 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
21843 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
21844 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
21845 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
21846 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
21847 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
21848 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
21849 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
21850 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
21851 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
21852 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21853 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21854 DATA (DL(K),K= 2211, 2295) /
21855 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21856 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21857 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21858 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21859 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21860 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21861 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
21862 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
21863 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
21864 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
21865 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
21866 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
21867 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
21868 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
21869 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
21870 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
21871 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
21872 DATA (DL(K),K= 2296, 2380) /
21873 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
21874 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
21875 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
21876 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
21877 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
21878 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
21879 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
21880 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
21881 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
21882 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
21883 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
21884 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
21885 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
21886 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21887 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21888 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21889 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21890 DATA (DL(K),K= 2381, 2465) /
21891 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21892 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21893 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21894 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21895 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
21896 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
21897 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
21898 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
21899 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
21900 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
21901 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
21902 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
21903 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
21904 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
21905 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
21906 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
21907 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
21908 DATA (DL(K),K= 2466, 2550) /
21909 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
21910 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
21911 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
21912 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
21913 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
21914 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
21915 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
21916 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
21917 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
21918 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
21919 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
21920 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21921 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21922 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21923 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21924 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21925 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21926 DATA (DL(K),K= 2551, 2635) /
21927 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21928 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21929 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
21930 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
21931 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
21932 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
21933 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
21934 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
21935 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
21936 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
21937 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
21938 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
21939 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
21940 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
21941 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
21942 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
21943 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
21944 DATA (DL(K),K= 2636, 2720) /
21945 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
21946 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
21947 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
21948 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
21949 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
21950 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
21951 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
21952 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
21953 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
21954 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21955 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21956 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21957 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21958 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21959 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21960 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21961 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21962 DATA (DL(K),K= 2721, 2805) /
21963 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
21964 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
21965 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
21966 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
21967 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
21968 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
21969 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
21970 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
21971 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
21972 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
21973 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
21974 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
21975 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
21976 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
21977 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
21978 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
21979 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
21980 DATA (DL(K),K= 2806, 2890) /
21981 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
21982 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
21983 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
21984 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
21985 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
21986 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
21987 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
21988 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21989 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21990 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21991 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21992 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21993 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21994 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21995 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21996 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
21997 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
21998 DATA (DL(K),K= 2891, 2975) /
21999 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
22000 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
22001 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
22002 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
22003 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
22004 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
22005 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
22006 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
22007 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
22008 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
22009 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
22010 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
22011 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
22012 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
22013 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
22014 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
22015 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
22016 DATA (DL(K),K= 2976, 3060) /
22017 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
22018 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
22019 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
22020 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
22021 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
22022 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22023 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22024 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22025 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22026 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22027 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22028 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22029 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22030 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
22031 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
22032 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
22033 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
22034 DATA (DL(K),K= 3061, 3145) /
22035 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
22036 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
22037 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
22038 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
22039 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
22040 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
22041 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
22042 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
22043 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
22044 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
22045 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
22046 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
22047 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
22048 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
22049 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
22050 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
22051 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
22052 DATA (DL(K),K= 3146, 3230) /
22053 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
22054 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
22055 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
22056 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22057 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22058 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22059 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22060 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22061 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22062 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22063 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22064 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
22065 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
22066 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
22067 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
22068 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
22069 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
22070 DATA (DL(K),K= 3231, 3315) /
22071 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
22072 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
22073 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
22074 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
22075 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
22076 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
22077 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
22078 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
22079 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
22080 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
22081 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
22082 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
22083 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
22084 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
22085 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
22086 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
22087 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
22088 DATA (DL(K),K= 3316, 3400) /
22089 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
22090 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22091 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22092 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22093 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22094 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22095 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22096 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22097 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22098 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
22099 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
22100 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
22101 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
22102 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
22103 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
22104 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
22105 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
22106 DATA (DL(K),K= 3401, 3485) /
22107 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
22108 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
22109 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
22110 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
22111 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
22112 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
22113 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
22114 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
22115 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
22116 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
22117 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
22118 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
22119 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
22120 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
22121 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
22122 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
22123 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22124 DATA (DL(K),K= 3486, 3570) /
22125 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22126 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22127 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22128 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22129 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22130 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22131 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22132 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
22133 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
22134 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
22135 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
22136 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
22137 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
22138 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
22139 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
22140 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
22141 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
22142 DATA (DL(K),K= 3571, 3655) /
22143 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
22144 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
22145 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
22146 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
22147 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
22148 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
22149 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
22150 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
22151 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
22152 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
22153 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
22154 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
22155 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
22156 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
22157 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22158 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22159 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22160 DATA (DL(K),K= 3656, 3740) /
22161 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22162 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22163 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22164 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22165 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22166 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
22167 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
22168 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
22169 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
22170 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
22171 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
22172 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
22173 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
22174 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
22175 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
22176 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
22177 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
22178 DATA (DL(K),K= 3741, 3825) /
22179 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
22180 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
22181 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
22182 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
22183 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
22184 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
22185 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
22186 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
22187 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
22188 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
22189 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
22190 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
22191 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22192 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22193 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22194 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22195 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22196 DATA (DL(K),K= 3826, 3910) /
22197 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22198 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22199 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22200 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
22201 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
22202 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
22203 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
22204 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
22205 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
22206 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
22207 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
22208 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
22209 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
22210 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
22211 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
22212 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
22213 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
22214 DATA (DL(K),K= 3911, 3995) /
22215 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
22216 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
22217 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
22218 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
22219 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
22220 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
22221 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
22222 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
22223 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
22224 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
22225 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22226 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22227 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22228 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22229 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22230 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22231 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22232 DATA (DL(K),K= 3996, 4000) /
22233 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22236 IF (X.GT.0.9985) RETURN
22237 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
22243 F1(L) = GF(I,IS,KL)
22244 F2(L) = GF(I,IS1,KL)
22246 A1 = DT_CKMTFF(X,F1)
22247 A2 = DT_CKMTFF(X,F2)
22252 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
22258 CDECK ID>, DT_CKMTPR
22259 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
22261 C**********************************************************************
22263 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22265 C This version by S. Roesler, 31.01.96
22266 C**********************************************************************
22269 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22270 EQUIVALENCE (GF(1,1,1),DL(1))
22273 DATA (DL(K),K= 1, 85) /
22274 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22275 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
22276 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
22277 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
22278 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
22279 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
22280 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
22281 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
22282 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
22283 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
22284 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
22285 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
22286 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
22287 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
22288 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
22289 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
22290 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
22291 DATA (DL(K),K= 86, 170) /
22292 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
22293 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
22294 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
22295 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
22296 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
22297 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
22298 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
22299 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
22300 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
22301 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
22302 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
22303 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
22304 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
22305 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
22306 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22307 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22308 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
22309 DATA (DL(K),K= 171, 255) /
22310 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
22311 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
22312 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
22313 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
22314 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
22315 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
22316 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
22317 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
22318 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
22319 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
22320 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
22321 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
22322 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
22323 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
22324 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
22325 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
22326 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
22327 DATA (DL(K),K= 256, 340) /
22328 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
22329 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
22330 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
22331 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
22332 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
22333 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
22334 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
22335 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
22336 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
22337 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
22338 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
22339 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
22340 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22341 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22342 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
22343 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
22344 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
22345 DATA (DL(K),K= 341, 425) /
22346 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
22347 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
22348 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
22349 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
22350 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
22351 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
22352 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
22353 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
22354 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
22355 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
22356 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
22357 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
22358 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
22359 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
22360 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
22361 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
22362 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
22363 DATA (DL(K),K= 426, 510) /
22364 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
22365 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
22366 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
22367 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
22368 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
22369 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
22370 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
22371 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
22372 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
22373 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22374 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22375 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22376 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
22377 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
22378 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
22379 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
22380 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
22381 DATA (DL(K),K= 511, 595) /
22382 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
22383 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
22384 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
22385 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
22386 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
22387 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
22388 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
22389 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
22390 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
22391 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
22392 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
22393 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
22394 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
22395 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
22396 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
22397 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
22398 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
22399 DATA (DL(K),K= 596, 680) /
22400 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
22401 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
22402 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
22403 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
22404 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
22405 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
22406 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
22407 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22408 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22409 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22410 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
22411 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
22412 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
22413 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
22414 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
22415 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
22416 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
22417 DATA (DL(K),K= 681, 765) /
22418 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
22419 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
22420 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
22421 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
22422 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
22423 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
22424 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
22425 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
22426 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
22427 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
22428 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
22429 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
22430 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
22431 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
22432 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
22433 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
22434 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
22435 DATA (DL(K),K= 766, 850) /
22436 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
22437 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
22438 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
22439 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
22440 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
22441 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22442 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22443 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22444 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
22445 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
22446 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
22447 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
22448 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
22449 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
22450 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
22451 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
22452 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
22453 DATA (DL(K),K= 851, 935) /
22454 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
22455 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
22456 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
22457 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
22458 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
22459 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
22460 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
22461 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
22462 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
22463 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
22464 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
22465 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
22466 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
22467 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
22468 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
22469 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
22470 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
22471 DATA (DL(K),K= 936, 1020) /
22472 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
22473 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
22474 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
22475 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22476 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22477 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22478 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
22479 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
22480 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
22481 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
22482 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
22483 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
22484 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
22485 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
22486 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
22487 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
22488 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
22489 DATA (DL(K),K= 1021, 1105) /
22490 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
22491 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
22492 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
22493 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
22494 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
22495 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
22496 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
22497 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
22498 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
22499 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
22500 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
22501 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
22502 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
22503 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
22504 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
22505 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
22506 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
22507 DATA (DL(K),K= 1106, 1190) /
22508 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
22509 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
22510 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22511 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22512 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
22513 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
22514 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
22515 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
22516 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
22517 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
22518 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
22519 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
22520 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
22521 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
22522 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
22523 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
22524 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
22525 DATA (DL(K),K= 1191, 1275) /
22526 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
22527 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
22528 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
22529 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
22530 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
22531 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
22532 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
22533 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
22534 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
22535 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
22536 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
22537 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
22538 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
22539 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
22540 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
22541 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
22542 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
22543 DATA (DL(K),K= 1276, 1360) /
22544 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22545 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22546 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
22547 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
22548 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
22549 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
22550 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
22551 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
22552 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
22553 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
22554 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
22555 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
22556 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
22557 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
22558 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
22559 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
22560 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
22561 DATA (DL(K),K= 1361, 1445) /
22562 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
22563 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
22564 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
22565 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
22566 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
22567 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
22568 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
22569 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
22570 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
22571 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
22572 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
22573 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
22574 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
22575 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
22576 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
22577 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22578 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22579 DATA (DL(K),K= 1446, 1530) /
22580 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
22581 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
22582 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
22583 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
22584 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
22585 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
22586 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
22587 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
22588 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
22589 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
22590 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
22591 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
22592 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
22593 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
22594 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
22595 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
22596 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
22597 DATA (DL(K),K= 1531, 1615) /
22598 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
22599 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
22600 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
22601 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
22602 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
22603 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
22604 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
22605 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
22606 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
22607 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
22608 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
22609 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
22610 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
22611 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22612 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22613 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
22614 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
22615 DATA (DL(K),K= 1616, 1700) /
22616 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
22617 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
22618 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
22619 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
22620 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
22621 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
22622 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
22623 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
22624 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
22625 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
22626 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
22627 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
22628 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
22629 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
22630 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
22631 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
22632 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
22633 DATA (DL(K),K= 1701, 1785) /
22634 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
22635 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
22636 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
22637 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
22638 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
22639 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
22640 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
22641 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
22642 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
22643 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
22644 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
22645 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22646 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22647 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
22648 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
22649 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
22650 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
22651 DATA (DL(K),K= 1786, 1870) /
22652 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
22653 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
22654 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
22655 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
22656 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
22657 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
22658 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
22659 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
22660 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
22661 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
22662 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
22663 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
22664 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
22665 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
22666 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
22667 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
22668 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
22669 DATA (DL(K),K= 1871, 1955) /
22670 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
22671 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
22672 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
22673 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
22674 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
22675 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
22676 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
22677 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
22678 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
22679 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22680 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22681 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
22682 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
22683 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
22684 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
22685 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
22686 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
22687 DATA (DL(K),K= 1956, 2040) /
22688 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
22689 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
22690 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
22691 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
22692 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
22693 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
22694 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
22695 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
22696 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
22697 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
22698 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
22699 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
22700 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
22701 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
22702 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
22703 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
22704 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
22705 DATA (DL(K),K= 2041, 2125) /
22706 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
22707 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
22708 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
22709 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
22710 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
22711 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
22712 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
22713 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22714 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22715 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
22716 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
22717 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
22718 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
22719 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
22720 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
22721 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
22722 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
22723 DATA (DL(K),K= 2126, 2210) /
22724 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
22725 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
22726 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
22727 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
22728 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
22729 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
22730 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
22731 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
22732 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
22733 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
22734 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
22735 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
22736 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
22737 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
22738 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
22739 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
22740 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
22741 DATA (DL(K),K= 2211, 2295) /
22742 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
22743 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
22744 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
22745 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
22746 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
22747 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22748 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
22749 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
22750 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
22751 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
22752 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
22753 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
22754 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
22755 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
22756 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
22757 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
22758 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
22759 DATA (DL(K),K= 2296, 2380) /
22760 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
22761 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
22762 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
22763 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
22764 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
22765 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
22766 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
22767 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
22768 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
22769 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
22770 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
22771 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
22772 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
22773 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
22774 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
22775 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
22776 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
22777 DATA (DL(K),K= 2381, 2465) /
22778 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
22779 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
22780 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
22781 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22782 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
22783 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
22784 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
22785 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
22786 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
22787 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
22788 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
22789 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
22790 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
22791 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
22792 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
22793 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
22794 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
22795 DATA (DL(K),K= 2466, 2550) /
22796 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
22797 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
22798 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
22799 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
22800 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
22801 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
22802 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
22803 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
22804 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
22805 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
22806 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
22807 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
22808 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
22809 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
22810 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
22811 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
22812 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
22813 DATA (DL(K),K= 2551, 2635) /
22814 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
22815 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22816 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
22817 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
22818 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
22819 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
22820 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
22821 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
22822 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
22823 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
22824 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
22825 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
22826 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
22827 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
22828 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
22829 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
22830 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
22831 DATA (DL(K),K= 2636, 2720) /
22832 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
22833 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
22834 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
22835 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
22836 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
22837 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
22838 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
22839 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
22840 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
22841 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
22842 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
22843 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
22844 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
22845 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
22846 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
22847 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
22848 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22849 DATA (DL(K),K= 2721, 2805) /
22850 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
22851 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
22852 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
22853 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
22854 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
22855 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
22856 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
22857 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
22858 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
22859 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
22860 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
22861 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
22862 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
22863 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
22864 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
22865 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
22866 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
22867 DATA (DL(K),K= 2806, 2890) /
22868 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
22869 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
22870 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
22871 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
22872 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
22873 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
22874 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
22875 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
22876 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
22877 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
22878 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
22879 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
22880 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
22881 &0.176404E-02,0.181381E-04,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.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
22884 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
22885 DATA (DL(K),K= 2891, 2975) /
22886 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
22887 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
22888 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
22889 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
22890 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
22891 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
22892 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
22893 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
22894 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
22895 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
22896 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
22897 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
22898 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
22899 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
22900 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
22901 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
22902 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
22903 DATA (DL(K),K= 2976, 3060) /
22904 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
22905 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
22906 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
22907 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
22908 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
22909 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
22910 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
22911 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
22912 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
22913 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
22914 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
22915 &0.883469E-03,0.711035E-05,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.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
22918 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
22919 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
22920 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
22921 DATA (DL(K),K= 3061, 3145) /
22922 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
22923 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
22924 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
22925 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
22926 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
22927 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
22928 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
22929 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
22930 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
22931 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
22932 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
22933 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
22934 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
22935 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
22936 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
22937 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
22938 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
22939 DATA (DL(K),K= 3146, 3230) /
22940 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
22941 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
22942 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
22943 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
22944 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
22945 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
22946 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
22947 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
22948 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
22949 &0.409096E-03,0.244427E-05,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.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
22952 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
22953 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
22954 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
22955 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
22956 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
22957 DATA (DL(K),K= 3231, 3315) /
22958 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
22959 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
22960 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
22961 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
22962 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
22963 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
22964 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
22965 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
22966 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
22967 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
22968 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
22969 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
22970 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
22971 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
22972 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
22973 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
22974 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
22975 DATA (DL(K),K= 3316, 3400) /
22976 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
22977 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
22978 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
22979 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
22980 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
22981 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
22982 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
22983 &0.169376E-03,0.676674E-06,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.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
22986 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
22987 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
22988 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
22989 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
22990 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
22991 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
22992 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
22993 DATA (DL(K),K= 3401, 3485) /
22994 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
22995 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
22996 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
22997 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
22998 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
22999 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
23000 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
23001 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
23002 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
23003 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
23004 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
23005 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
23006 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
23007 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
23008 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
23009 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
23010 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
23011 DATA (DL(K),K= 3486, 3570) /
23012 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
23013 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
23014 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
23015 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
23016 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
23017 &0.593824E-04,0.126902E-06,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.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
23020 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
23021 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
23022 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
23023 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
23024 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
23025 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
23026 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
23027 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
23028 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
23029 DATA (DL(K),K= 3571, 3655) /
23030 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
23031 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
23032 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
23033 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
23034 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
23035 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
23036 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
23037 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
23038 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
23039 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
23040 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
23041 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
23042 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
23043 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
23044 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
23045 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
23046 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
23047 DATA (DL(K),K= 3656, 3740) /
23048 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
23049 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
23050 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
23051 &0.159423E-04,0.180204E-07,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.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23054 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
23055 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
23056 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
23057 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
23058 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
23059 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
23060 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
23061 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
23062 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
23063 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
23064 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
23065 DATA (DL(K),K= 3741, 3825) /
23066 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
23067 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
23068 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
23069 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
23070 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
23071 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
23072 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
23073 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
23074 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
23075 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
23076 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
23077 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
23078 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
23079 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
23080 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
23081 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
23082 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
23083 DATA (DL(K),K= 3826, 3910) /
23084 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
23085 &0.261981E-05,0.331859E-08,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.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23088 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
23089 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
23090 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
23091 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
23092 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
23093 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
23094 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
23095 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
23096 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
23097 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
23098 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
23099 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
23100 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
23101 DATA (DL(K),K= 3911, 3995) /
23102 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
23103 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
23104 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
23105 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
23106 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
23107 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
23108 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
23109 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
23110 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
23111 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
23112 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
23113 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
23114 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
23115 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
23116 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
23117 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
23118 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
23119 DATA (DL(K),K= 3996, 4000) /
23120 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23123 IF (X.GT.0.9985) RETURN
23124 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23130 F1(L) = GF(I,IS,KL)
23131 F2(L) = GF(I,IS1,KL)
23133 A1 = DT_CKMTFF(X,F1)
23134 A2 = DT_CKMTFF(X,F2)
23139 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23144 CDECK ID>, DT_CKMTFF
23145 FUNCTION DT_CKMTFF(X,FVL)
23146 C**********************************************************************
23148 C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
23149 C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
23150 C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
23153 C**********************************************************************
23156 DIMENSION FVL(25),XGRID(25)
23157 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
23158 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
23162 IF(X.LT.XGRID(I)) GO TO 2
23167 ELSE IF(I.GT.23) THEN
23173 BXI=LOG(1.-XGRID(I))
23175 BXJ=LOG(1.-XGRID(J))
23177 BXK=LOG(1.-XGRID(K))
23178 FI=LOG(ABS(FVL(I)) +1.E-15)
23179 FJ=LOG(ABS(FVL(J)) +1.E-16)
23180 FK=LOG(ABS(FVL(K)) +1.E-17)
23181 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
23182 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
23184 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
23185 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
23186 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
23188 C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
23189 C WRITE(6,2001) X,FVL
23190 C 2001 FORMAT(8E12.4)
23191 C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
23193 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
23197 *===fluini=============================================================*
23199 CDECK ID>, DT_FLUINI
23200 SUBROUTINE DT_FLUINI
23202 ************************************************************************
23203 * Initialisation of the nucleon-nucleon cross section fluctuation *
23204 * treatment. The original version by J. Ranft. *
23205 * This version dated 21.04.95 is revised by S. Roesler. *
23206 ************************************************************************
23208 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23211 PARAMETER ( LINP = 5 ,
23215 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
23217 PARAMETER ( A = 0.1D0,
23223 * n-n cross section fluctuations
23224 PARAMETER (NBINS = 1000)
23225 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
23226 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
23229 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
23238 FLUS = ((X-B)/(OM*B))**N
23239 IF (FLUS.LE.20.0D0) THEN
23240 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
23244 FLUSU = FLUSU+FLUSI(I)
23247 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
23252 C1001 FORMAT(1X,'FLUCTUATIONS')
23253 C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
23256 AF = DBLE(I)*0.001D0
23258 IF (AF.LE.FLUSI(J)) THEN
23259 FLUIXX(I) = FLUIX(J)
23265 FLUIXX(1) = FLUIX(1)
23266 FLUIXX(NBINS) = FLUIX(NBINS)
23271 *===sigtab=============================================================*
23273 CDECK ID>, DT_SIGTBL
23274 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
23276 ************************************************************************
23277 * This version dated 18.11.95 is written by S. Roesler *
23278 ************************************************************************
23280 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23283 PARAMETER ( LINP = 5 ,
23287 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
23288 & OHALF=0.5D0,ONE=1.0D0)
23289 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
23293 * particle properties (BAMJET index convention)
23295 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
23296 & IICH(210),IIBAR(210),K1(210),K2(210)
23298 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
23299 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
23300 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
23302 DATA LINIT /.FALSE./
23304 * precalculation and tabulation of elastic cross sections
23305 IF (ABS(MODE).EQ.1) THEN
23307 & OPEN(LDAT,FILE='sigtab.out',STATUS='UNKNOWN')
23308 PLABLX = LOG10(PLO)
23309 PLABHX = LOG10(PHI)
23310 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
23312 PLAB = PLABLX+DBLE(I-1)*DPLAB
23317 C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
23318 C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
23320 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
23321 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
23324 IF (MODE.EQ.1) THEN
23325 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
23326 & (SIGEN(IDX,I),IDX=1,5)
23327 1000 FORMAT(F5.1,10F7.2)
23330 IF (MODE.EQ.1) CLOSE(LDAT)
23334 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
23335 & .AND.(PTOT.LE.PHI) ) THEN
23337 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
23338 PLABX = LOG10(PTOT)
23339 IF (PLABX.LE.PLABLX) THEN
23342 ELSEIF (PLABX.GE.PLABHX) THEN
23346 I1 = INT((PLABX-PLABLX)/DPLAB)+1
23349 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
23350 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
23351 PBIN = PLAB2X-PLAB1X
23352 IF (PBIN.GT.TINY10) THEN
23353 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
23358 SIG1 = SIGEP(IDX,I1)
23359 SIG2 = SIGEP(IDX,I2)
23361 SIG1 = SIGEN(IDX,I1)
23362 SIG2 = SIGEN(IDX,I2)
23364 SIGE = SIG1+RATX*(SIG2-SIG1)
23372 *===xstabl=============================================================*
23374 CDECK ID>, DT_XSTABL
23375 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
23377 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23380 PARAMETER ( LINP = 5 ,
23384 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
23385 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
23386 LOGICAL LLAB,LELOG,LQLOG
23388 * particle properties (BAMJET index convention)
23390 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
23391 & IICH(210),IIBAR(210),K1(210),K2(210)
23392 * properties of interacting particles
23393 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
23395 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
23397 * Glauber formalism: cross sections
23398 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
23399 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
23400 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
23401 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
23402 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
23403 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
23404 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
23405 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
23406 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
23407 & BSLOPE,NEBINI,NQBINI
23408 * emulsion treatment
23409 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
23414 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
23417 IF (ELO.GT.EHI) ELO = EHI
23418 LELOG = WHAT(3).LT.ZERO
23419 NEBINS = MAX(INT(ABS(WHAT(3))),1)
23420 DEBINS = (EHI-ELO)/DBLE(NEBINS)
23424 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
23428 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
23429 LQLOG = WHAT(6).LT.ZERO
23430 NQBINS = MAX(INT(ABS(WHAT(6))),1)
23431 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
23433 AQ2LO = LOG10(Q2LO)
23434 AQ2HI = LOG10(Q2HI)
23435 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
23438 IF ( ELO.EQ. EHI) NEBINS = 0
23439 IF (Q2LO.EQ.Q2HI) NQBINS = 0
23441 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
23442 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
23443 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
23444 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
23445 & ' A_p = ',I3,' A_t = ',I3,/)
23447 C IF (IJPROJ.NE.7) THEN
23448 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
23449 * normalize fractions of emulsion components
23450 IF (NCOMPO.GT.0) THEN
23453 SUMFRA = SUMFRA+EMUFRA(I)
23455 IF (SUMFRA.GT.ZERO) THEN
23457 EMUFRA(I) = EMUFRA(I)/SUMFRA
23462 C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
23466 E = 10**(AELO+DBLE(I-1)*ADEBIN)
23468 E = ELO+DBLE(I-1)*DEBINS
23472 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
23474 Q2 = Q2LO+DBLE(J-1)*DQBINS
23476 c IF (IJPROJ.NE.7) THEN
23480 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
23486 IF (IJPROJ.EQ.7) Q2I = Q2
23487 IF (NCOMPO.GT.0) THEN
23490 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
23493 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
23494 C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
23496 IF (NCOMPO.GT.0) THEN
23515 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
23516 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
23517 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
23518 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
23519 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
23520 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
23521 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
23522 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
23523 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
23524 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
23525 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
23526 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
23527 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
23528 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
23529 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
23530 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
23531 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
23532 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
23534 XPRO1= XPRO1+EMUFRA(IC)*YPRO
23544 WRITE(LOUT,'(8E9.3)')
23545 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
23546 C WRITE(LOUT,'(4E9.3)')
23547 C & E,XDEL,XDQE,XDEL+XDQE
23549 WRITE(LOUT,'(11E10.3)')
23551 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
23552 & XSQE2(1,1,1),XSPRO(1,1,1),
23553 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
23554 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
23555 & XSDEL(1,1,1)+XSDQE(1,1,1)
23556 C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
23557 C & XSDEL(1,1,1)+XSDQE(1,1,1)
23561 c IF (IT.GT.1) THEN
23562 c IF (IXSQEL.EQ.0) THEN
23563 cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
23564 cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
23565 c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
23566 c & STOT,ETOT,SIN,EIN,STOT0)
23567 c IF (IRATIO.EQ.1) THEN
23568 c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
23569 cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
23570 cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
23571 c*!! save cross sections
23576 c STOT = STOT/(DBLE(IT)*STGP)
23577 c SIN = SIN/(DBLE(IT)*SIGP)
23584 c & ' XSTABL: qel. xs. not implemented for nuclei'
23591 c IF (IXSQEL.EQ.0) THEN
23592 c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
23595 c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
23599 c IF (IT.GT.1) THEN
23600 c IF (IXSQEL.EQ.0) THEN
23601 c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
23602 c & STOT,ETOT,SIN,EIN,STOT0)
23603 c IF (IRATIO.EQ.1) THEN
23604 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
23605 c*!! save cross sections
23610 c STOT = STOT/(DBLE(IT)*STGP)
23611 c SIN = SIN/(DBLE(IT)*SIGP)
23618 c & ' XSTABL: qel. xs. not implemented for nuclei'
23625 c IF (IXSQEL.EQ.0) THEN
23626 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
23629 c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
23633 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
23634 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
23635 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
23636 c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
23644 *===testxs=============================================================*
23646 CDECK ID>, DT_TESTXS
23647 SUBROUTINE DT_TESTXS
23649 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23652 DIMENSION XSTOT(26,2),XSELA(26,2)
23654 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
23655 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
23656 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
23657 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
23662 APLABL = LOG10(PLABL)
23663 APLABH = LOG10(PLABH)
23664 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
23666 ADP = APLABL+DBLE(I-1)*ADPLAB
23669 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
23670 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
23672 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
23673 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
23674 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
23675 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
23677 1000 FORMAT(F8.3,26F9.3)
23681 ************************************************************************
23683 * DTUNUC 2.0: library routines *
23684 * processed by S. Roesler, 6.5.95 *
23686 ************************************************************************
23688 * 1) Handling of parton momenta
23689 * SUBROUTINE MASHEL
23690 * SUBROUTINE DFERMI
23692 * 2) Handling of parton flavors and particle indices
23693 * INTEGER FUNCTION IPDG2B
23694 * INTEGER FUNCTION IB2PDG
23695 * INTEGER FUNCTION IQUARK
23696 * INTEGER FUNCTION IBJQUA
23697 * INTEGER FUNCTION ICIHAD
23698 * INTEGER FUNCTION IPDGHA
23699 * INTEGER FUNCTION MCHAD
23700 * SUBROUTINE FLAHAD
23702 * 3) Energy-momentum and quantum number conservation check routines
23705 * SUBROUTINE EVTEMC
23706 * SUBROUTINE EVTFLC
23707 * SUBROUTINE EVTCHG
23709 * 4) Transformations
23711 * SUBROUTINE LTRANS
23713 * SUBROUTINE DALTRA
23714 * SUBROUTINE DTRAFO
23715 * SUBROUTINE STTRAN
23716 * SUBROUTINE MYTRAN
23717 * SUBROUTINE LT2LAO
23718 * SUBROUTINE LT2LAB
23720 * 5) Sampling from distributions
23721 * INTEGER FUNCTION NPOISS
23722 * DOUBLE PRECISION FUNCTION SAMPXB
23723 * DOUBLE PRECISION FUNCTION SAMPEX
23724 * DOUBLE PRECISION FUNCTION SAMSQX
23725 * DOUBLE PRECISION FUNCTION BETREJ
23726 * DOUBLE PRECISION FUNCTION DGAMRN
23727 * DOUBLE PRECISION FUNCTION DBETAR
23728 * SUBROUTINE RANNOR
23730 * SUBROUTINE DSFECF
23733 * 6) Special functions, algorithms and service routines
23734 * DOUBLE PRECISION FUNCTION YLAMB
23737 * SUBROUTINE DT_XTIME
23739 * 7) Random number generator package
23740 * DOUBLE PRECISION FUNCTION DT_RNDM
23741 * SUBROUTINE DT_RNDMST
23742 * SUBROUTINE DT_RNDMIN
23743 * SUBROUTINE DT_RNDMOU
23744 * SUBROUTINE DT_RNDMTE
23746 ************************************************************************
23748 * 1) Handling of parton momenta *
23750 ************************************************************************
23752 *===mashel=============================================================*
23754 CDECK ID>, DT_MASHEL
23755 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
23757 ************************************************************************
23759 * rescaling of momenta of two partons to put both *
23762 * input: PA1,PA2 input momentum vectors *
23763 * XM1,2 desired masses of particles afterwards *
23764 * P1,P2 changed momentum vectors *
23766 * The original version is written by R. Engel. *
23767 * This version dated 12.12.94 is modified by S. Roesler. *
23768 ************************************************************************
23770 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23773 PARAMETER ( LINP = 5 ,
23777 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
23779 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
23783 * Lorentz transformation into system CMS
23788 XPTOT = SQRT(PX**2+PY**2+PZ**2)
23789 XMS = (EE-XPTOT)*(EE+XPTOT)
23790 IF(XMS.LT.(XM1+XM2)**2) THEN
23791 C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
23799 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
23800 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
23803 C SID = SQRT((ONE-COD)*(ONE+COD))
23804 PPT = SQRT(P1(1)**2+P1(2)**2)
23808 IF(PTOT1*SID.GT.TINY10) THEN
23809 COF = P1(1)/(SID*PTOT1)
23810 SIF = P1(2)/(SID*PTOT1)
23811 ANORF = SQRT(COF*COF+SIF*SIF)
23815 * new CM momentum and energies (for masses XM1,XM2)
23816 XM12 = SIGN(XM1**2,XM1)
23817 XM22 = SIGN(XM2**2,XM2)
23819 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
23820 EE1 = SQRT(XM12+PCMP**2)
23824 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
23825 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
23826 & PTOT1,P1(1),P1(2),P1(3),P1(4))
23827 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
23828 & PTOT2,P2(1),P2(2),P2(3),P2(4))
23829 * check consistency
23831 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
23833 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
23835 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
23837 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
23842 IF (IDEV.NE.0) THEN
23843 WRITE(LOUT,'(/1X,A,I3)')
23844 & 'MASHEL: inconsistent transformation',IDEV
23845 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
23846 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
23847 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
23848 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
23849 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
23850 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
23859 *===dfermi=============================================================*
23861 CDECK ID>, DT_DFERMI
23862 SUBROUTINE DT_DFERMI(GPART)
23864 ************************************************************************
23865 * Find largest of three random numbers. *
23866 ************************************************************************
23868 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23874 G(I)=DT_RNDM(GPART)
23876 IF (G(3).LT.G(2)) GOTO 40
23877 IF (G(3).LT.G(1)) GOTO 30
23882 40 IF (G(2).LT.G(1)) GOTO 30
23888 ************************************************************************
23890 * 2) Handling of parton flavors and particle indices *
23892 ************************************************************************
23894 *===ipdg2b=============================================================*
23896 CDECK ID>, IDT_IPDG2B
23897 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
23899 ************************************************************************
23901 * conversion of quark numbering scheme *
23903 * input: PDG parton numbering *
23904 * for diquarks: NN number of the constituent quark *
23905 * (e.g. ID=2301,NN=1 -> ICONV2=1) *
23907 * output: BAMJET particle codes *
23908 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
23909 * 2 d 8 a-d -2 a-d *
23910 * 3 s 9 a-s -3 a-s *
23911 * 4 c 10 a-c -4 a-c *
23913 * This is a modified version of ICONV2 written by R. Engel. *
23914 * This version dated 13.12.94 is written by S. Roesler. *
23915 ************************************************************************
23917 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23920 PARAMETER ( LINP = 5 ,
23928 IF (IDA.GE.1000) KF = 4
23929 IDA = IDA/(10**(KF-NN))
23932 * exchange up and dn quarks
23935 ELSEIF (IDA.EQ.2) THEN
23940 IF (MODE.EQ.1) THEN
23951 *===ib2pdg=============================================================*
23953 CDECK ID>, IDT_IB2PDG
23954 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
23956 ************************************************************************
23958 * conversion of quark numbering scheme *
23960 * input: BAMJET particle codes *
23961 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
23962 * 2 d 8 a-d -2 a-d *
23963 * 3 s 9 a-s -3 a-s *
23964 * 4 c 10 a-c -4 a-c *
23966 * output: PDG parton numbering *
23968 * This version dated 13.12.94 is written by S. Roesler. *
23969 ************************************************************************
23971 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23974 PARAMETER ( LINP = 5 ,
23978 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
23979 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
23980 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
23981 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
23982 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
23986 IF (MODE.EQ.1) THEN
23987 IF (ID1.GT.6) IDA = -(ID1-6)
23988 IF (ID2.GT.6) IDB = -(ID2-6)
23991 IDT_IB2PDG = IHKKQ(IDA)
23993 IDT_IB2PDG = IHKKQQ(IDA,IDB)
23999 *===ipdgqu=============================================================*
24001 CDECK ID>, IDT_IQUARK
24002 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
24004 ************************************************************************
24006 * quark contents according to PDG conventions *
24007 * (random selection in case of quark mixing) *
24009 * input: IDBAMJ BAMJET particle code *
24010 * K 1..3 quark number *
24012 * output: 1 d (anti --> neg.) *
24017 * This version written by R. Engel. *
24018 ************************************************************************
24020 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24023 IQ = IDT_IBJQUA(K,IDBAMJ)
24028 * exchange of up and down
24029 IF (ABS(IQ).EQ.1) THEN
24031 ELSEIF (ABS(IQ).EQ.2) THEN
24039 *===ibamq==============================================================*
24041 CDECK ID>, IDT_IBJQUA
24042 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
24044 ************************************************************************
24046 * quark contents according to BAMJET conventions *
24047 * (random selection in case of quark mixing) *
24049 * input: IDBAMJ BAMJET particle code *
24050 * K 1..3 quark number *
24052 * output: 1 u 7 u bar *
24057 * This version written by R. Engel. *
24058 ************************************************************************
24060 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24063 DIMENSION ITAB(3,210)
24064 DATA ((ITAB(I,K),I=1,3),K=1,30) /
24065 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
24066 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24067 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
24069 C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24070 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
24072 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
24074 C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
24075 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
24077 C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
24078 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
24080 & 1, 2, 3, 201,202, 0, 2, 9, 0,
24081 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
24082 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
24083 DATA ((ITAB(I,K),I=1,3),K=31,60) /
24084 & 3, 9, 0, 1, 8, 0, 203,204, 0,
24085 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
24086 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
24087 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24088 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24089 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24090 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24091 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
24092 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
24093 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
24094 DATA ((ITAB(I,K),I=1,3),K=61,90) /
24095 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24096 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24097 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
24098 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
24099 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24100 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24101 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24102 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24103 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24104 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
24105 DATA ((ITAB(I,K),I=1,3),K=91,120) /
24106 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24107 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
24108 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
24109 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
24110 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
24111 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
24112 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
24113 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
24114 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
24115 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
24116 DATA ((ITAB(I,K),I=1,3),K=121,150) /
24117 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
24118 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
24119 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
24120 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24121 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24122 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
24123 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
24124 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
24125 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
24126 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
24127 DATA ((ITAB(I,K),I=1,3),K=151,180) /
24128 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
24129 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
24130 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
24131 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
24132 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
24133 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
24134 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
24135 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
24136 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
24137 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
24138 DATA ((ITAB(I,K),I=1,3),K=181,210) /
24139 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24140 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24141 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24142 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24143 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24144 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24145 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
24146 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
24147 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24148 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
24152 IF (ITAB(1,IDBAMJ).LE.200) THEN
24153 ID = ITAB(K,IDBAMJ)
24155 IF(IDOLD.NE.IDBAMJ) THEN
24156 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
24157 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
24169 *===icihad=============================================================*
24171 CDECK ID>, IDT_ICIHAD
24172 INTEGER FUNCTION IDT_ICIHAD(MCIND)
24174 ************************************************************************
24175 * Conversion of particle index PDG proposal --> BAMJET-index scheme *
24176 * This is a completely new version dated 25.10.95. *
24177 * Renamed to be not in conflict with the modified PHOJET-version *
24178 ************************************************************************
24180 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24183 * hadron index conversion (BAMJET <--> PDG)
24184 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
24185 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
24190 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
24191 IF (MCIND.LT.0) THEN
24196 IF (KPDG.GE.10000) THEN
24198 IDT_ICIHAD = IBAM5(JSIGN,I)
24199 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
24202 ELSEIF (KPDG.GE.1000) THEN
24204 IDT_ICIHAD = IBAM4(JSIGN,I)
24205 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
24208 ELSEIF (KPDG.GE.100) THEN
24210 IDT_ICIHAD = IBAM3(JSIGN,I)
24211 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
24214 ELSEIF (KPDG.GE.10) THEN
24216 IDT_ICIHAD = IBAM2(JSIGN,I)
24217 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
24226 *===ipdgha=============================================================*
24228 CDECK ID>, IDT_IPDGHA
24229 INTEGER FUNCTION IDT_IPDGHA(MCIND)
24231 ************************************************************************
24232 * Conversion of particle index BAMJET-index scheme --> PDG proposal *
24233 * Adopted from the original by S. Roesler. This version dated 12.5.95 *
24234 * Renamed to be not in conflict with the modified PHOJET-version *
24235 ************************************************************************
24237 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24240 * hadron index conversion (BAMJET <--> PDG)
24241 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
24242 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
24245 IDT_IPDGHA = IAMCIN(MCIND)
24250 *===flahad=============================================================*
24252 CDECK ID>, DT_FLAHAD
24253 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
24255 ************************************************************************
24256 * sampling of FLAvor composition for HADrons/photons *
24257 * ID BAMJET-id of hadron *
24258 * IF1,2,3 flavor content *
24259 * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
24260 * Note: - u,d numbering as in BAMJET *
24261 * - ID .le. 30 !! *
24262 * This version dated 12.03.96 is written by S. Roesler *
24263 ************************************************************************
24265 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24268 * auxiliary common for reggeon exchange (DTUNUC 1.x)
24269 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
24270 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
24271 & IQTCHR(-6:6),MQUARK(3,39)
24273 DIMENSION JSEL(3,6)
24274 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
24278 * photon (charge dependent flavour sampling)
24279 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
24283 ELSE IF(K.EQ.5) THEN
24290 IF(DT_RNDM(ONE).LT.0.5D0) THEN
24298 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
24299 IF1 = MQUARK(JSEL(1,IX),ID)
24300 IF2 = MQUARK(JSEL(2,IX),ID)
24301 IF3 = MQUARK(JSEL(3,IX),ID)
24302 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
24305 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
24314 *===mchad==============================================================*
24316 CDECK ID>, IDT_MCHAD
24317 INTEGER FUNCTION IDT_MCHAD(ITDTU)
24319 ************************************************************************
24320 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
24321 * Adopted from the original by S. Roesler. This version dated 6.5.95 *
24322 ************************************************************************
24324 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24327 DIMENSION ITRANS(210)
24328 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
24329 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
24330 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
24331 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
24332 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
24333 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
24334 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
24336 IDT_MCHAD = ITRANS(ITDTU)
24341 ************************************************************************
24343 * 3) Energy-momentum and quantum number conservation check routines *
24345 ************************************************************************
24347 *===emc1===============================================================*
24350 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
24352 ************************************************************************
24353 * This version dated 15.12.94 is written by S. Roesler *
24354 ************************************************************************
24356 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24359 PARAMETER ( LINP = 5 ,
24363 PARAMETER (TINY10=1.0D-10)
24365 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
24369 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
24370 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
24372 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
24373 IF (MODE.EQ.1) THEN
24374 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
24375 ELSEIF (MODE.EQ.2) THEN
24376 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
24378 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
24379 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
24380 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
24381 ELSEIF (MODE.LT.0) THEN
24382 IF (MODE.EQ.-1) THEN
24383 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
24384 ELSEIF (MODE.EQ.-2) THEN
24385 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
24387 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
24388 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
24389 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
24392 IF (ABS(MODE).EQ.3) THEN
24393 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
24394 IF (IREJ1.NE.0) GOTO 9999
24403 *===emc2===============================================================*
24406 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
24409 ************************************************************************
24410 * MODE = 1 energy-momentum cons. check *
24411 * = 2 flavor-cons. check *
24412 * = 3 energy-momentum & flavor cons. check *
24413 * = 4 energy-momentum & charge cons. check *
24414 * = 5 energy-momentum & flavor & charge cons. check *
24415 * This version dated 16.01.95 is written by S. Roesler *
24416 ************************************************************************
24418 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24421 PARAMETER ( LINP = 5 ,
24425 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
24429 PARAMETER (NMXHKK=200000)
24431 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
24432 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
24433 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
24434 * extended event history
24435 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
24436 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
24444 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
24445 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
24446 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24447 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
24448 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
24450 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
24451 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
24452 & (ISTHKK(I).EQ.IP5)) THEN
24453 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
24455 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
24457 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24458 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
24459 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
24460 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
24462 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
24463 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
24464 & (ISTHKK(I).EQ.IN5)) THEN
24465 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
24467 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
24469 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24470 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
24471 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
24472 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
24475 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
24476 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
24477 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24478 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
24479 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
24480 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
24489 *===evtemc=============================================================*
24491 CDECK ID>, DT_EVTEMC
24492 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
24494 ************************************************************************
24495 * This version dated 13.12.94 is written by S. Roesler *
24496 ************************************************************************
24498 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24501 PARAMETER ( LINP = 5 ,
24505 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
24510 PARAMETER (NMXHKK=200000)
24512 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
24513 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
24514 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
24515 * flags for input different options
24516 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
24517 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
24518 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
24524 IF (MODE.EQ.4) THEN
24527 ELSEIF (MODE.EQ.5) THEN
24530 ELSEIF (MODE.EQ.-1) THEN
24535 IF (ABS(MODE).EQ.3) THEN
24540 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
24541 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
24542 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
24543 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
24544 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
24545 & ' event ',NEVHKK,
24546 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
24560 IF (MODE.EQ.1) THEN
24579 *===evtflc=============================================================*
24581 CDECK ID>, DT_EVTFLC
24582 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
24584 ************************************************************************
24585 * Flavor conservation check. *
24586 * ID identity of particle *
24587 * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
24588 * = 2 ID for particle/resonance in BAMJET numbering scheme *
24589 * = 3 ID for particle/resonance in PDG numbering scheme *
24590 * MODE = 1 initialization and add ID *
24591 * =-1 initialization and subtract ID *
24593 * =-2 subtract ID *
24594 * = 3 check flavor cons. *
24595 * IPOS flag to give position of call of EVTFLC to output *
24596 * unit in case of violation *
24597 * This version dated 10.01.95 is written by S. Roesler *
24598 ************************************************************************
24600 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24603 PARAMETER ( LINP = 5 ,
24607 PARAMETER (TINY10=1.0D-10)
24611 IF (MODE.EQ.3) THEN
24613 WRITE(LOUT,'(1X,A,I3,A,I3)')
24614 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
24623 IF (MODE.EQ.1) IFL = 0
24624 IF (ID.EQ.0) RETURN
24629 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
24630 IF (IDD.GE.1000) NQ = 3
24632 IFBAM = IDT_IPDG2B(ID,I,2)
24633 IF (ABS(IFBAM).EQ.1) THEN
24634 IFBAM = SIGN(2,IFBAM)
24635 ELSEIF (ABS(IFBAM).EQ.2) THEN
24636 IFBAM = SIGN(1,IFBAM)
24638 IF (MODE.GT.0) THEN
24648 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
24649 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
24651 IF (MODE.GT.0) THEN
24652 IFL = IFL+IDT_IQUARK(I,IDD)
24654 IFL = IFL-IDT_IQUARK(I,IDD)
24665 *===evtchg=============================================================*
24667 CDECK ID>, DT_EVTCHG
24668 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
24670 ************************************************************************
24671 * Charge conservation check. *
24672 * ID identity of particle (PDG-numbering scheme) *
24673 * MODE = 1 initialization *
24674 * =-2 subtract ID-charge *
24675 * = 2 add ID-charge *
24676 * = 3 check charge cons. *
24677 * IPOS flag to give position of call of EVTCHG to output *
24678 * unit in case of violation *
24679 * This version dated 10.01.95 is written by S. Roesler *
24680 * Last change: s.r. 21.01.01 *
24681 ************************************************************************
24683 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24686 PARAMETER ( LINP = 5 ,
24692 PARAMETER (NMXHKK=200000)
24694 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
24695 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
24696 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
24697 * particle properties (BAMJET index convention)
24699 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24700 & IICH(210),IIBAR(210),K1(210),K2(210)
24704 IF (MODE.EQ.1) THEN
24710 IF (MODE.EQ.3) THEN
24711 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
24712 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
24713 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
24714 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
24724 IF (ID.EQ.0) RETURN
24726 IDD = IDT_ICIHAD(ID)
24727 * modification 21.1.01: use intrinsic phojet-functions to determine charge
24728 * and baryon number
24729 C IF (IDD.GT.0) THEN
24730 C IF (MODE.EQ.2) THEN
24731 C ICH = ICH+IICH(IDD)
24732 C IBAR = IBAR+IIBAR(IDD)
24733 C ELSEIF (MODE.EQ.-2) THEN
24734 C ICH = ICH-IICH(IDD)
24735 C IBAR = IBAR-IIBAR(IDD)
24738 C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
24739 C CALL DT_EVTOUT(4)
24742 IF (MODE.EQ.2) THEN
24743 ICH = ICH+IPHO_CHR3(ID,1)/3
24744 IBAR = IBAR+IPHO_BAR3(ID,1)/3
24745 ELSEIF (MODE.EQ.-2) THEN
24746 ICH = ICH-IPHO_CHR3(ID,1)/3
24747 IBAR = IBAR-IPHO_BAR3(ID,1)/3
24757 ************************************************************************
24759 * 4) Transformations *
24761 ************************************************************************
24763 *===ltini==============================================================*
24765 CDECK ID>, DT_LTINI
24766 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
24768 ************************************************************************
24769 * Initializations of Lorentz-transformations, calculation of Lorentz- *
24771 * This version dated 13.11.95 is written by S. Roesler. *
24772 ************************************************************************
24774 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24777 PARAMETER ( LINP = 5 ,
24781 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
24782 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
24784 * Lorentz-parameters of the current interaction
24785 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
24786 & UMO,PPCM,EPROJ,PPROJ
24787 * properties of photon/lepton projectiles
24788 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
24789 * particle properties (BAMJET index convention)
24791 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24792 & IICH(210),IIBAR(210),K1(210),K2(210)
24793 * nucleon-nucleon event-generator
24796 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
24800 IF (MCGENE.NE.3) THEN
24801 * lepton-projectiles and PHOJET: initialize real photon instead
24802 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
24803 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
24804 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
24813 AMP = AAM(IDP)-SQRT(ABS(Q2))
24815 AMP2 = SIGN(AMP**2,AMP)
24817 IF (ECM0.GT.ZERO) THEN
24818 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
24819 IF (AMP2.GT.ZERO) THEN
24820 PPN = SQRT((EPN+AMP)*(EPN-AMP))
24822 PPN = SQRT(EPN**2-AMP2)
24825 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
24826 IF (IDP.EQ.7) EPN = ABS(EPN)
24827 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
24828 IF (AMP2.GT.ZERO) THEN
24829 PPN = SQRT((EPN+AMP)*(EPN-AMP))
24831 PPN = SQRT(EPN**2-AMP2)
24833 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24834 IF (AMP2.GT.ZERO) THEN
24835 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
24837 EPN = SQRT(PPN**2+AMP2)
24840 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
24845 IF (AMP2.GT.ZERO) THEN
24846 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
24847 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
24852 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
24858 IF (ECM0.GT.ZERO) THEN
24861 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
24862 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
24863 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24864 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
24867 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
24868 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
24869 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
24870 IF (MODE.EQ.1) THEN
24873 PNUCL(3) = -PGAMM(3)
24874 PNUCL(4) = SQRT(S)-PGAMM(4)
24877 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
24878 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
24881 * neglect lepton masses
24882 C AMLPT2 = AAM(IDPR)**2
24885 IF (ECM0.GT.ZERO) THEN
24888 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
24889 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
24890 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24891 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
24894 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
24895 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
24896 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
24899 PNUCL(3) = -PLEPT0(3)
24900 PNUCL(4) = SQRT(S)-PLEPT0(4)
24902 * Lorentz-parameter for transformation Lab. - projectile rest system
24903 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
24912 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
24917 GACMS(1) = (ETARG+AMP)/UMO
24918 BGCMS(1) = PTARG/UMO
24920 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
24921 GACMS(2) = (EPROJ+AMT)/UMO
24922 BGCMS(2) = PPROJ/UMO
24923 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
24932 *===ltrans=============================================================*
24934 CDECK ID>, DT_LTRANS
24935 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
24937 ************************************************************************
24938 * Lorentz-transformations. *
24939 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
24940 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
24941 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
24942 * This version dated 01.11.95 is written by S. Roesler. *
24943 ************************************************************************
24945 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24948 PARAMETER ( LINP = 5 ,
24952 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
24954 PARAMETER (SQTINF=1.0D+15)
24956 * particle properties (BAMJET index convention)
24958 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24959 & IICH(210),IIBAR(210),K1(210),K2(210)
24963 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
24965 * check particle mass for consistency (numerical rounding errors)
24966 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
24967 AMO2 = (PEO-PO)*(PEO+PO)
24968 AMORQ2 = AAM(ID)**2
24969 AMDIF2 = ABS(AMO2-AMORQ2)
24970 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
24971 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
24977 C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
24983 *===ltnuc==============================================================*
24985 CDECK ID>, DT_LTNUC
24986 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
24988 ************************************************************************
24989 * Lorentz-transformations. *
24990 * PIN longitudnal momentum (input) *
24991 * EIN energy (input) *
24992 * POUT transformed long. momentum (output) *
24993 * EOUT transformed energy (output) *
24994 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
24995 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
24996 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
24997 * This version dated 01.11.95 is written by S. Roesler. *
24998 ************************************************************************
25000 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25003 PARAMETER ( LINP = 5 ,
25007 PARAMETER (ZERO=0.0D0)
25009 * Lorentz-parameters of the current interaction
25010 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25011 & UMO,PPCM,EPROJ,PPROJ
25017 IF (ABS(MODE).EQ.1) THEN
25018 BG = -SIGN(BGLAB,DBLE(MODE))
25019 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
25020 & DUM1,DUM2,DUM3,POUT,EOUT)
25021 ELSEIF (ABS(MODE).EQ.2) THEN
25022 BG = SIGN(BGCMS(1),DBLE(MODE))
25023 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
25024 & DUM1,DUM2,DUM3,POUT,EOUT)
25025 ELSEIF (ABS(MODE).EQ.3) THEN
25026 BG = -SIGN(BGCMS(2),DBLE(MODE))
25027 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
25028 & DUM1,DUM2,DUM3,POUT,EOUT)
25030 WRITE(LOUT,1000) MODE
25031 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
25039 *===daltra=============================================================*
25041 CDECK ID>, DT_DALTRA
25042 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
25044 ************************************************************************
25045 * Arbitrary Lorentz-transformation. *
25046 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
25047 ************************************************************************
25049 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25051 PARAMETER (ONE=1.0D0)
25053 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
25054 PE = EP/(GA+ONE)+EC
25058 P = SQRT(PX*PX+PY*PY+PZ*PZ)
25064 *====dtrafo============================================================*
25066 CDECK ID>, DT_DTRAFO
25067 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
25068 & PL,CXL,CYL,CZL,EL)
25070 C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
25072 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25075 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
25076 SID = SQRT(1.D0-COD*COD)
25080 PLZ = GAM*PCMZ+BGAM*ECM
25081 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
25082 EL = GAM*ECM+BGAM*PCMZ
25083 C ROTATION INTO THE ORIGINAL DIRECTION
25085 SIZ = SQRT(1.D0-COZ**2)
25086 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
25091 *====sttran============================================================*
25093 CDECK ID>, DT_STTRAN
25094 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
25096 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25098 DATA ANGLSQ/1.D-30/
25099 ************************************************************************
25100 * VERSION BY J. RANFT *
25103 * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
25105 * INPUT VARIABLES: *
25106 * XO,YO,ZO = ORIGINAL DIRECTION COSINES *
25107 * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
25108 * ANGLE OF "SCATTERING" *
25109 * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
25110 * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
25111 * OF "SCATTERING" *
25113 * OUTPUT VARIABLES: *
25114 * X,Y,Z = NEW DIRECTION COSINES *
25116 * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
25117 ************************************************************************
25120 * Changed by A. Ferrari
25122 * IF (ABS(XO)-0.0001D0) 1,1,2
25123 * 1 IF (ABS(YO)-0.0001D0) 3,3,2
25126 IF ( A .LT. ANGLSQ ) THEN
25135 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
25136 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
25143 *===mytran=============================================================*
25145 CDECK ID>, DT_MYTRAN
25146 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
25148 ************************************************************************
25149 * This subroutine rotates the coordinate frame *
25150 * a) theta around y *
25151 * b) phi around z if IMODE = 1 *
25153 * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
25154 * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
25155 * z' 0 0 1 -sin(th) 0 cos(th) z *
25157 * and vice versa if IMODE = 0. *
25158 * This version dated 5.4.94 is based on the original version DTRAN *
25159 * by J. Ranft and is written by S. Roesler. *
25160 ************************************************************************
25162 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25165 PARAMETER ( LINP = 5 ,
25169 IF (IMODE.EQ.1) THEN
25170 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
25171 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
25172 Z=-SDE *XO +CDE *ZO
25174 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
25176 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
25181 *===lt2lab=============================================================*
25183 CDECK ID>, DT_LT2LAO
25184 SUBROUTINE DT_LT2LAO
25186 ************************************************************************
25187 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
25188 * for final state particles/fragments defined in nucleon-nucleon-cms *
25189 * and transforms them back to the lab. *
25190 * This version dated 16.11.95 is written by S. Roesler *
25191 ************************************************************************
25193 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25196 PARAMETER ( LINP = 5 ,
25202 PARAMETER (NMXHKK=200000)
25204 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25205 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25206 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25207 * extended event history
25208 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25209 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25214 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
25215 DO 1 I=NPOINT(4),NEND
25217 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
25218 & (ISTHKK(I).EQ.1001)) THEN
25219 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
25221 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
25222 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
25223 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
25224 ISTHKK(I) = 3*ISTHKK(I)
25227 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
25228 ISTHKK(I) = SIGN(3,ISTHKK(I))
25237 *===lt2lab=============================================================*
25239 CDECK ID>, DT_LT2LAB
25240 SUBROUTINE DT_LT2LAB
25242 ************************************************************************
25243 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
25244 * for final state particles/fragments defined in nucleon-nucleon-cms *
25245 * and transforms them to the lab. *
25246 * This version dated 07.01.96 is written by S. Roesler *
25247 ************************************************************************
25249 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25252 PARAMETER ( LINP = 5 ,
25258 PARAMETER (NMXHKK=200000)
25260 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25261 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25262 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25263 * extended event history
25264 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25265 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25268 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
25269 DO 1 I=NPOINT(4),NHKK
25270 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
25271 & (ISTHKK(I).EQ.1001)) THEN
25272 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
25281 ************************************************************************
25283 * 5) Sampling from distributions *
25285 ************************************************************************
25287 *===npoiss=============================================================*
25289 CDECK ID>, IDT_NPOISS
25290 INTEGER FUNCTION IDT_NPOISS(AVN)
25292 ************************************************************************
25293 * Sample according to Poisson distribution with Poisson parameter AVN. *
25294 * The original version written by J. Ranft. *
25295 * This version dated 11.1.95 is written by S. Roesler. *
25296 ************************************************************************
25298 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25301 PARAMETER ( LINP = 5 ,
25311 IF (A.GE.EXPAVN) THEN
25320 *===sampxb=============================================================*
25322 CDECK ID>, DT_SAMPXB
25323 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
25325 ************************************************************************
25326 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
25327 * Processed by S. Roesler, 6.5.95 *
25328 ************************************************************************
25330 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25332 PARAMETER (TWO=2.0D0)
25334 A1 = LOG(X1+SQRT(X1**2+B**2))
25335 A2 = LOG(X2+SQRT(X2**2+B**2))
25337 A = AN*DT_RNDM(A1)+A1
25339 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
25344 *===sampex=============================================================*
25346 CDECK ID>, DT_SAMPEX
25347 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
25349 ************************************************************************
25350 * Sampling from f(x)=1./x between x1 and x2. *
25351 * Processed by S. Roesler, 6.5.95 *
25352 ************************************************************************
25354 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25356 PARAMETER (ONE=1.0D0)
25361 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
25366 *===samsqx=============================================================*
25368 CDECK ID>, DT_SAMSQX
25369 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
25371 ************************************************************************
25372 * Sampling from f(x)=1./x^0.5 between x1 and x2. *
25373 * Processed by S. Roesler, 6.5.95 *
25374 ************************************************************************
25376 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25378 PARAMETER (ONE=1.0D0)
25381 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
25386 *===samplw=============================================================*
25388 CDECK ID>, DT_SAMPLW
25389 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
25391 ************************************************************************
25392 * Sampling from f(x)=1/x^b between x_min and x_max. *
25393 * S. Roesler, 18.4.98 *
25394 ************************************************************************
25396 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25398 PARAMETER (ONE=1.0D0)
25402 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
25405 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
25411 *===betrej=============================================================*
25413 CDECK ID>, DT_BETREJ
25414 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
25416 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25419 PARAMETER ( LINP = 5 ,
25423 PARAMETER (ONE=1.0D0)
25425 IF (XMIN.GE.XMAX)THEN
25426 WRITE (LOUT,500) XMIN,XMAX
25427 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
25432 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
25433 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
25434 YY = BETMAX*DT_RNDM(XX)
25435 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
25436 IF (YY.GT.BETXX) GOTO 10
25442 *===dgamrn=============================================================*
25444 CDECK ID>, DT_DGAMRN
25445 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
25447 ************************************************************************
25448 * Sampling from Gamma-distribution. *
25449 * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
25450 * Processed by S. Roesler, 6.5.95 *
25451 ************************************************************************
25453 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25455 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
25460 IF (F.EQ.ZERO) GOTO 20
25463 IF (NCOU.GE.11) GOTO 20
25464 IF (R.LT.F/(F+2.71828D0)) GOTO 30
25465 YYY = LOG(DT_RNDM(R)+TINY9)/F
25466 IF (ABS(YYY).GT.50.0D0) GOTO 20
25468 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
25472 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
25473 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
25474 40 IF (N.EQ.0) GOTO 70
25477 60 Z = Z*DT_RNDM(Z)
25479 70 DT_DGAMRN = Y/ALAM
25484 *===dbetar=============================================================*
25486 CDECK ID>, DT_DBETAR
25487 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
25489 ************************************************************************
25490 * Sampling from Beta -distribution between 0.0 and 1.0 *
25491 * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
25492 * Processed by S. Roesler, 6.5.95 *
25493 ************************************************************************
25495 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25498 Y = DT_DGAMRN(1.0D0,GAM)
25499 Z = DT_DGAMRN(1.0D0,ETA)
25500 DT_DBETAR = Y/(Y+Z)
25505 *===rannor=============================================================*
25507 CDECK ID>, DT_RANNOR
25508 SUBROUTINE DT_RANNOR(X,Y)
25510 ************************************************************************
25511 * Sampling from Gaussian distribution. *
25512 * Processed by S. Roesler, 6.5.95 *
25513 ************************************************************************
25515 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25517 PARAMETER (TINY10=1.0D-10)
25519 CALL DT_DSFECF(SFE,CFE)
25520 V = MAX(TINY10,DT_RNDM(X))
25521 A = SQRT(-2.D0*LOG(V))
25528 *===dpoli==============================================================*
25530 CDECK ID>, DT_DPOLI
25531 SUBROUTINE DT_DPOLI(CS,SI)
25533 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25538 IF (U.LT.0.5D0) CS=-CS
25539 SI = SQRT(1.0D0-CS*CS+1.0D-10)
25544 *===dsfecf=============================================================*
25546 CDECK ID>, DT_DSFECF
25547 SUBROUTINE DT_DSFECF(SFE,CFE)
25549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25551 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
25559 IF (XY.GT.ONE) GOTO 1
25562 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
25566 *===raco===============================================================*
25569 SUBROUTINE DT_RACO(WX,WY,WZ)
25571 ************************************************************************
25572 * Direction cosines of random uniform (isotropic) direction in three *
25573 * dimensional space *
25574 * Processed by S. Roesler, 20.11.95 *
25575 ************************************************************************
25577 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25579 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
25582 X = TWO*DT_RNDM(WX)-ONE
25586 IF (X2+Y2.GT.ONE) GOTO 10
25588 CFE = (X2-Y2)/(X2+Y2)
25589 SFE = TWO*X*Y/(X2+Y2)
25590 * z = 1/2 [ 1 + cos (theta) ]
25593 WZ = SQRT(Z*(ONE-Z))
25601 ************************************************************************
25603 * 6) Special functions, algorithms and service routines *
25605 ************************************************************************
25607 *===ylamb==============================================================*
25609 CDECK ID>, DT_YLAMB
25610 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
25612 ************************************************************************
25614 * auxiliary function for three particle decay mode *
25615 * (standard LAMBDA**(1/2) function) *
25617 * Adopted from an original version written by R. Engel. *
25618 * This version dated 12.12.94 is written by S. Roesler. *
25619 ************************************************************************
25621 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25625 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
25626 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
25627 DT_YLAMB = SQRT(XLAM)
25632 *===sort1==============================================================*
25635 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
25637 ************************************************************************
25638 * This subroutine sorts entries in A in increasing/decreasing order *
25640 * MODE = 1 increasing in A(3,i=1..N) *
25641 * = 2 decreasing in A(3,i=1..N) *
25642 * This version dated 21.04.95 is revised by S. Roesler *
25643 ************************************************************************
25645 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25657 IF (MODE.EQ.1) THEN
25658 IF (A(3,I).LE.A(3,J)) GOTO 20
25660 IF (A(3,I).GE.A(3,J)) GOTO 20
25673 IF (L.EQ.1) GOTO 10
25678 *===sort1==============================================================*
25680 CDECK ID>, DT_SORT1
25681 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
25683 ************************************************************************
25684 * This subroutine sorts entries in A in increasing/decreasing order *
25686 * MODE = 1 increasing in A(i=1..N) *
25687 * = 2 decreasing in A(i=1..N) *
25688 * This version dated 21.04.95 is revised by S. Roesler *
25689 ************************************************************************
25691 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25694 DIMENSION A(N),IDX(N)
25703 IF (MODE.EQ.1) THEN
25704 IF (A(I).LE.A(J)) GOTO 20
25706 IF (A(I).GE.A(J)) GOTO 20
25716 IF (L.EQ.1) GOTO 10
25721 *===xtime==============================================================*
25723 CDECK ID>, DT_XTIME
25724 SUBROUTINE DT_XTIME
25726 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25729 PARAMETER ( LINP = 5 ,
25733 CHARACTER DAT*9,TIM*11
25737 C CALL GETDAT(IYEAR,IMONTH,IDAY)
25738 C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
25742 C WRITE(LOUT,1000) DAT,TIM
25743 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
25748 ************************************************************************
25750 * 7) Random number generator package *
25752 * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
25753 * SERVICE ROUTINES. *
25754 * THE ALGORITHM IS FROM *
25755 * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
25756 * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
25757 * IMPLEMENTATION BY K. HAHN DEC. 88, *
25758 * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
25759 * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
25760 * THE PERIOD IS ABOUT 2**144, *
25761 * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
25762 * THE PACKAGE CONTAINS *
25763 * FUNCTION DT_RNDM(I) : GENERATOR *
25764 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
25765 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
25766 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
25767 * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
25769 * FUNCTION DT_RNDM(I) *
25770 * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
25771 * I - DUMMY VARIABLE, NOT USED *
25772 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
25773 * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
25774 * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
25775 * NA? MUST BE IN 1..178 AND NOT ALL 1 *
25776 * 12,34,56 ARE THE STANDARD VALUES *
25777 * NB1 MUST BE IN 1..168 *
25778 * 78 IS THE STANDARD VALUE *
25779 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
25780 * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
25781 * AS AFTER THE LAST DT_RNDMOU CALL ) *
25782 * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
25783 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
25784 * TAKES SEED FROM GENERATOR *
25785 * U(97),C,CD,CM,I,J - SEED VALUES *
25786 * SUBROUTINE DT_RNDMTE(IO) *
25787 * TEST OF THE GENERATOR *
25788 * IO - DEFINES OUTPUT *
25789 * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
25790 * = 1 OUTPUT INDEPENDEND ON AN ERROR *
25791 * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
25793 * AS BEFORE CALL OF DT_RNDMTE *
25794 ************************************************************************
25796 *===rndm===============================================================*
25799 DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
25801 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25804 * counter of calls to random number generator
25805 * uncomment if needed
25806 C COMMON /DTRNCT/ IRNCT0,IRNCT1
25808 C DATA LFIRST /.TRUE./
25810 * counter of calls to random number generator
25811 * uncomment if needed
25818 DT_RNDM = FLRNDM(VDUMMY)
25819 * counter of calls to random number generator
25820 * uncomment if needed
25821 C IRNCT1 = IRNCT1+1
25826 *===rndmst=============================================================*
25828 CDECK ID>, DT_RNDMST
25829 SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
25831 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25834 * random number generator
25835 COMMON /DTRAND/ U(97),C,CD,CM,I,J
25847 MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
25851 MB1 = MOD(53*MB1+1,169)
25852 IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
25855 C = 362436.0D0/16777216.0D0
25856 CD = 7654321.0D0/16777216.0D0
25857 CM = 16777213.0D0/16777216.0D0
25861 *===rndmin=============================================================*
25863 CDECK ID>, DT_RNDMIN
25864 SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
25866 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25869 * random number generator
25870 COMMON /DTRAND/ U(97),C,CD,CM,I,J
25875 10 U(KKK) = UIN(KKK)
25885 *===rndmou=============================================================*
25887 CDECK ID>, DT_RNDMOU
25888 SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
25890 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25893 * random number generator
25894 COMMON /DTRAND/ U(97),C,CD,CM,I,J
25899 10 UOUT(KKK) = U(KKK)
25909 *===rndmte=============================================================*
25911 CDECK ID>, DT_RNDMTE
25912 SUBROUTINE DT_RNDMTE(IO)
25914 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25917 DIMENSION UU(97),U(6),X(6),D(6)
25918 DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
25919 +8354498.D0, 10633180.D0/
25921 CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
25922 CALL DT_RNDMST(12,34,56,78)
25923 DO 10 II1 = 1,20000
25924 10 XX = DT_RNDM(XX)
25927 X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
25928 D(II2) = X(II2)-U(II2)
25930 CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
25932 C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
25933 IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
25935 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
25940 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
25941 &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
25942 &1,F20.1,F15.3,/), ' === END OF TEST ;',
25943 &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
25947 *===title==============================================================*
25949 CDECK ID>, DT_TITLE
25950 SUBROUTINE DT_TITLE
25952 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25955 PARAMETER ( LINP = 5 ,
25960 CHARACTER*11 CCHANG
25961 DATA CVERSI,CCHANG /'3.0-4 ','18 Sep 2001'/
25964 WRITE(LOUT,1000) CVERSI,CCHANG
25965 1000 FORMAT(1X,'+-------------------------------------------------',
25966 & '----------------------+',/,
25967 & 1X,'|',71X,'|',/,
25968 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
25969 & 1X,'|',71X,'|',/,
25970 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
25971 & 1X,'|',71X,'|',/,
25972 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
25973 & 1X,'|',21X,'Ralph Engel (Bartol Res. Inst.)',14X,'|',/,
25974 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
25975 & 1X,'|',71X,'|',/,
25976 & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
25978 & 1X,'|',71X,'|',/,
25979 & 1X,'+-------------------------------------------------',
25980 & '----------------------+',/,
25981 & 1X,'| Please send suggestions, bug reports, etc. to: ',
25982 & 'Stefan.Roesler@cern.ch |',/,
25983 & 1X,'+-------------------------------------------------',
25984 & '----------------------+',/)
25989 *===evtini=============================================================*
25991 CDECK ID>, DT_EVTINI
25992 SUBROUTINE DT_EVTINI
25994 ************************************************************************
25995 * Initialization of DTEVT1. *
25996 * This version dated 15.01.94 is written by S. Roesler *
25997 ************************************************************************
25999 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26002 PARAMETER ( LINP = 5 ,
26008 PARAMETER (NMXHKK=200000)
26010 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26011 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26012 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26013 * extended event history
26014 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26015 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26018 COMMON /DTEVNO/ NEVENT,ICASCA
26020 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
26022 * emulsion treatment
26023 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
26026 * initialization of DTEVT1/DTEVT2
26028 IF (NEVENT.EQ.1) NEND = NMXHKK
26056 C* initialization of DTLTRA
26057 C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
26062 *===statis=============================================================*
26064 CDECK ID>, DT_STATIS
26065 SUBROUTINE DT_STATIS(MODE)
26067 ************************************************************************
26068 * Initialization and output of run-statistics. *
26069 * MODE = 1 initialization *
26071 * This version dated 23.01.94 is written by S. Roesler *
26072 ************************************************************************
26074 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26077 PARAMETER ( LINP = 5 ,
26081 PARAMETER (TINY3=1.0D-3)
26084 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
26085 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
26087 * rejection counter
26088 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
26089 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
26090 & IREXCI(3),IRDIFF(2),IRINC
26091 * central particle production, impact parameter biasing
26092 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
26093 * various options for treatment of partons (DTUNUC 1.x)
26094 * (chain recombination, Cronin,..)
26095 LOGICAL LCO2CR,LINTPT
26096 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
26098 * nucleon-nucleon event-generator
26101 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26102 * flags for particle decays
26103 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
26104 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
26105 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
26106 * diquark-breaking mechanism
26107 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
26109 DIMENSION PP(4),PT(4)
26116 * initialize statistics counter
26129 * initialize rejection counter
26160 * statistics counter
26162 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
26163 & 28X,'---------------------')
26164 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
26165 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
26166 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
26167 & 'event',11X,F9.1)
26168 IF (ICDIFF(1).NE.0) THEN
26169 WRITE(LOUT,1009) ICDIFF
26170 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
26171 & 'low mass high mass',/,24X,'single diffraction',
26172 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
26174 IF (ICENTR.GT.0) THEN
26175 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
26176 & DBLE(ICSAMP)/DBLE(ICCPRO)
26177 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
26178 & ' of sampled Glauber-events per event',9X,F9.1,/,
26179 & 2X,'fraction of production cross section',21X,F10.6)
26181 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
26182 & DBLE(ICDTA)/DBLE(ICSAMP)
26183 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
26184 & ' nucleons after x-sampling',2(4X,F6.2))
26186 IF (MCGENE.EQ.1) THEN
26187 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
26188 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
26189 & ' event',3X,F9.1)
26190 IF (ISICHA.EQ.1) THEN
26191 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
26192 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
26193 & 'of single chains per event',13X,F9.1)
26196 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
26197 & 23X,'mean number of chains mean number of chains',/,
26198 & 23X,'sampled hadronized having mass of a reso.')
26199 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
26200 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
26201 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
26202 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
26203 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26204 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26205 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26206 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26207 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26208 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26209 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26210 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26211 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
26213 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
26214 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
26215 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
26216 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
26217 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
26218 & DBLE(IRHHA)/DBLE(ICREQU),
26219 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
26220 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
26221 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
26222 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
26223 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
26224 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
26225 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
26226 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
26227 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
26228 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
26229 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
26230 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
26231 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
26232 & F7.2,/,1X,'Total no. of rej.',
26233 & ' in chain-systems treatment (GETCSY)',/,43X,
26234 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
26235 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
26236 & 1X,'Total no. of rej. in DPM-treatment of one event',
26237 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
26238 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
26239 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
26240 & 'IREXCI(3) = ',I5,/)
26241 ELSEIF (MCGENE.EQ.2) THEN
26242 C *** Commented by Chiara
26243 C WRITE(LOUT,1010) ELOJET
26244 C 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
26247 C 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
26248 C & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
26249 C & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
26250 C WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
26251 C & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
26252 C & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
26253 C & ((ICEVTG(I,J),I=1,8),J=3,7),
26254 C & ((ICEVTG(I,J),I=1,8),J=19,21),
26255 C & (ICEVTG(I,8),I=1,8),
26256 C & ((ICEVTG(I,J),I=1,8),J=22,24),
26257 C & (ICEVTG(I,9),I=1,8),
26258 C & ((ICEVTG(I,J),I=1,8),J=25,28),
26259 C & ((ICEVTG(I,J),I=1,8),J=10,18)
26260 C 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
26261 C & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
26262 C & ' no-dif.',8I8,/,
26263 C & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
26264 C & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
26265 C & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
26266 C & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
26267 C & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
26268 C & ' hi-lo ',8I8,/,
26269 C & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
26270 C & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
26271 C & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
26273 C 1013 FORMAT(/,1X,'2. chain system statistics -',
26274 C & ' mean numbers per evt:',/,30X,'---------------------',
26275 C & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
26277 C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
26278 C & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
26279 C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
26280 C 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
26281 C & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
26282 C & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
26283 C & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
26284 C & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
26285 C & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
26286 C & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
26287 C & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
26288 C & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
26289 C & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
26291 C 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
26293 C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
26294 C & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
26295 C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
26296 C 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
26297 C & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
26298 C & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
26299 C & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
26300 C & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
26301 C & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
26302 C & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
26303 C & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
26304 C & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
26305 C & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
26310 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
26311 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
26312 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
26313 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
26314 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
26315 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
26316 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
26317 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
26318 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
26319 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
26320 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
26321 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
26322 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
26323 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
26324 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
26325 & DBRKA(3,1),DBRKA(3,2),
26326 & DBRKA(3,3),DBRKA(3,4)
26327 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
26328 & DBRKR(3,1),DBRKR(3,2),
26329 & DBRKR(3,3),DBRKR(3,4)
26330 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
26331 & DBRKA(3,5),DBRKA(3,6),
26332 & DBRKA(3,7),DBRKA(3,8)
26333 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
26334 & DBRKR(3,5),DBRKR(3,6),
26335 & DBRKR(3,7),DBRKR(3,8)
26339 IF (MCGENE.EQ.2) THEN
26341 C CALL PHO_PHIST(-2,SIGMAX)
26342 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
26351 *===evtout=============================================================*
26353 CDECK ID>, DT_EVTOUT
26354 SUBROUTINE DT_EVTOUT(MODE)
26356 ************************************************************************
26357 * MODE = 1 plot content of complete DTEVT1 to out. unit *
26358 * 3 plot entries of extended DTEVT1 (DTEVT2) *
26359 * 4 plot entries of DTEVT1 and DTEVT2 *
26360 * This version dated 11.12.94 is written by S. Roesler *
26361 ************************************************************************
26363 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26366 PARAMETER ( LINP = 5 ,
26372 PARAMETER (NMXHKK=200000)
26374 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26375 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26376 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26378 DIMENSION IRANGE(NMXHKK)
26380 IF (MODE.EQ.2) RETURN
26382 CALL DT_EVTPLO(IRANGE,MODE)
26387 *===evtplo=============================================================*
26389 CDECK ID>, DT_EVTPLO
26390 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
26392 ************************************************************************
26393 * MODE = 1 plot content of complete DTEVT1 to out. unit *
26394 * 2 plot entries of DTEVT1 given by IRANGE *
26395 * 3 plot entries of extended DTEVT1 (DTEVT2) *
26396 * 4 plot entries of DTEVT1 and DTEVT2 *
26397 * 5 plot rejection counter *
26398 * This version dated 11.12.94 is written by S. Roesler *
26399 ************************************************************************
26401 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26404 PARAMETER ( LINP = 5 ,
26412 PARAMETER (NMXHKK=200000)
26414 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26415 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26416 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26417 * extended event history
26418 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26419 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26421 * rejection counter
26422 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
26423 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
26424 & IREXCI(3),IRDIFF(2),IRINC
26426 DIMENSION IRANGE(NMXHKK)
26428 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
26430 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
26431 & 15X,' --------------------------',/,/,
26432 & ' ST ID M1 M2 D1 D2 PX PY',
26435 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26436 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26437 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
26439 C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26440 C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26441 C & PHKK(3,I),PHKK(4,I)
26442 C WRITE(LOUT,'(4E15.4)')
26443 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
26444 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
26445 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
26449 C WRITE(LOUT,1006) I,ISTHKK(I),
26450 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
26451 C & WHKK(2,I),WHKK(3,I)
26452 C1006 FORMAT(1X,I4,I6,6E10.3)
26456 IF (MODE.EQ.2) THEN
26461 IF (IRANGE(NC).EQ.-100) GOTO 9999
26463 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26464 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26465 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
26470 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
26472 1002 FORMAT(/,1X,'EVTPLO:',14X,
26473 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
26474 & 15X,' -----------------------------------',/,/,
26475 & ' ST ID M1 M2 D1 D2 IDR IDXR',
26476 & ' NOBAM IDCH M',/)
26478 C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
26481 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
26482 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
26484 CALL PYNAME(KF,CHAU)
26486 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26487 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26488 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
26490 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
26495 IF (MODE.EQ.5) THEN
26497 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
26498 & 15X,' --------------------------',/)
26499 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
26501 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
26502 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
26503 & 1X,'IREMC = ',10I5,/,
26504 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
26510 *===evtput=============================================================*
26512 CDECK ID>, DT_EVTPUT
26513 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
26515 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26518 PARAMETER ( LINP = 5 ,
26522 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
26523 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
26527 PARAMETER (NMXHKK=200000)
26529 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26530 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26531 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26532 * extended event history
26533 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26534 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26536 * Lorentz-parameters of the current interaction
26537 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26538 & UMO,PPCM,EPROJ,PPROJ
26539 * particle properties (BAMJET index convention)
26541 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26542 & IICH(210),IIBAR(210),K1(210),K2(210)
26544 C IF (MODE.GT.100) THEN
26545 C WRITE(LOUT,'(1X,A,I5,A,I5)')
26546 C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
26547 C NHKK = NHKK-MODE+100
26554 IF (NHKK.GT.NMXHKK) THEN
26555 WRITE(LOUT,1000) NHKK
26556 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
26557 & '! program execution stopped..')
26560 IF (M1.LT.0) MO1 = NHKK+M1
26561 IF (M2.LT.0) MO2 = NHKK+M2
26564 JMOHKK(1,NHKK) = MO1
26565 JMOHKK(2,NHKK) = MO2
26569 IDXRES(NHKK) = IDXR
26571 ** here we need to do something..
26572 IF (ID.EQ.88888) THEN
26573 IDMO1 = ABS(IDHKK(MO1))
26574 IDMO2 = ABS(IDHKK(MO2))
26575 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
26576 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
26577 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
26578 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
26582 IDBAM(NHKK) = IDT_ICIHAD(ID)
26584 IF (JDAHKK(1,MO1).NE.0) THEN
26585 JDAHKK(2,MO1) = NHKK
26587 JDAHKK(1,MO1) = NHKK
26591 IF (JDAHKK(1,MO2).NE.0) THEN
26592 JDAHKK(2,MO2) = NHKK
26594 JDAHKK(1,MO2) = NHKK
26597 C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
26598 C PTOT = SQRT(PX**2+PY**2+PZ**2)
26599 C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
26600 C AMRQ = AAM(IDBAM(NHKK))
26601 C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
26602 C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
26603 C & (PTOT.GT.ZERO)) THEN
26604 C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
26605 CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
26607 C PTOT1 = PTOT-DELTA
26608 C PX = PX*PTOT1/PTOT
26609 C PY = PY*PTOT1/PTOT
26610 C PZ = PZ*PTOT1/PTOT
26617 PTOT = SQRT( PX**2+PY**2+PZ**2 )
26618 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
26619 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
26620 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
26622 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
26623 C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
26624 C & WRITE(LOUT,'(1X,A,G10.3)')
26625 C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
26626 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
26629 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
26630 * special treatment for chains:
26631 * z coordinate of chain in Lab = pos. of target nucleon
26632 * time of chain-creation in Lab = time of passage of projectile
26633 * nucleus at pos. of taget nucleus
26634 C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
26635 C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
26636 VHKK(1,NHKK) = VHKK(1,MO2)
26637 VHKK(2,NHKK) = VHKK(2,MO2)
26638 VHKK(3,NHKK) = VHKK(3,MO2)
26639 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
26640 C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
26641 C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
26642 WHKK(1,NHKK) = WHKK(1,MO1)
26643 WHKK(2,NHKK) = WHKK(2,MO1)
26644 WHKK(3,NHKK) = WHKK(3,MO1)
26645 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
26649 VHKK(I,NHKK) = VHKK(I,MO1)
26650 WHKK(I,NHKK) = WHKK(I,MO1)
26654 VHKK(I,NHKK) = ZERO
26655 WHKK(I,NHKK) = ZERO
26663 *===chasta=============================================================*
26665 CDECK ID>, DT_CHASTA
26666 SUBROUTINE DT_CHASTA(MODE)
26668 ************************************************************************
26669 * This subroutine performs CHAin STAtistics and checks sequence of *
26670 * partons in dtevt1 and sorts them with projectile partons coming *
26671 * first if necessary. *
26673 * This version dated 8.5.00 is written by S. Roesler. *
26674 ************************************************************************
26676 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26679 PARAMETER ( LINP = 5 ,
26687 PARAMETER (NMXHKK=200000)
26689 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26690 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26691 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26692 * extended event history
26693 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26694 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26696 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
26697 PARAMETER (MAXCHN=10000)
26698 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
26700 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
26701 & CCHTYP(9),ICHSTA(10),ITOT(10)
26702 DATA ICHCFG /1800*0/
26703 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
26704 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
26705 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
26706 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
26707 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
26708 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
26709 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
26710 & 'ad aq',' d ad','ad d ',' g g '/
26714 IF (MODE.EQ.-1) THEN
26717 * loop over DTEVT1 and analyse chain configurations
26719 ELSEIF (MODE.EQ.0) THEN
26720 DO 21 IDX=NPOINT(3),NHKK
26721 IDCHK = IDHKK(IDX)/10000
26722 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
26723 & (IDHKK(IDX).NE.80000).AND.
26724 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
26725 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
26726 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
26731 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
26732 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
26734 IMO1 = IST1-10*IMO1
26736 IMO2 = IST2-10*IMO2
26737 * swop parton entries if necessary since we need projectile partons
26738 * to come first in the common
26739 IF (IMO1.GT.IMO2) THEN
26740 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
26742 I0 = JMOHKK(1,IDX)-1+K
26743 I1 = JMOHKK(2,IDX)+1-K
26745 ISTHKK(I0) = ISTHKK(I1)
26748 IDHKK(I0) = IDHKK(I1)
26750 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
26751 & JDAHKK(1,JMOHKK(1,I0)) = I1
26752 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
26753 & JDAHKK(2,JMOHKK(1,I0)) = I1
26754 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
26755 & JDAHKK(1,JMOHKK(2,I0)) = I1
26756 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
26757 & JDAHKK(2,JMOHKK(2,I0)) = I1
26758 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
26759 & JDAHKK(1,JMOHKK(1,I1)) = I0
26760 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
26761 & JDAHKK(2,JMOHKK(1,I1)) = I0
26762 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
26763 & JDAHKK(1,JMOHKK(2,I1)) = I0
26764 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
26765 & JDAHKK(2,JMOHKK(2,I1)) = I0
26766 ITMP = JMOHKK(1,I0)
26767 JMOHKK(1,I0) = JMOHKK(1,I1)
26768 JMOHKK(1,I1) = ITMP
26769 ITMP = JMOHKK(2,I0)
26770 JMOHKK(2,I0) = JMOHKK(2,I1)
26771 JMOHKK(2,I1) = ITMP
26772 ITMP = JDAHKK(1,I0)
26773 JDAHKK(1,I0) = JDAHKK(1,I1)
26774 JDAHKK(1,I1) = ITMP
26775 ITMP = JDAHKK(2,I0)
26776 JDAHKK(2,I0) = JDAHKK(2,I1)
26777 JDAHKK(2,I1) = ITMP
26782 PHKK(J,I0) = PHKK(J,I1)
26783 VHKK(J,I0) = VHKK(J,I1)
26784 WHKK(J,I0) = WHKK(J,I1)
26790 PHKK(5,I0) = PHKK(5,I1)
26793 IDRES(I0) = IDRES(I1)
26796 IDXRES(I0) = IDXRES(I1)
26799 NOBAM(I0) = NOBAM(I1)
26802 IDBAM(I0) = IDBAM(I1)
26805 IDCH(I0) = IDCH(I1)
26808 IHIST(1,I0) = IHIST(1,I1)
26811 IHIST(2,I0) = IHIST(2,I1)
26815 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
26816 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
26818 * parton 1 (projectile side)
26819 IF (IST1.EQ.21) THEN
26821 ELSEIF (IST1.EQ.22) THEN
26823 ELSEIF (IST1.EQ.31) THEN
26825 ELSEIF (IST1.EQ.32) THEN
26827 ELSEIF (IST1.EQ.41) THEN
26829 ELSEIF (IST1.EQ.42) THEN
26831 ELSEIF (IST1.EQ.51) THEN
26833 ELSEIF (IST1.EQ.52) THEN
26835 ELSEIF (IST1.EQ.61) THEN
26837 ELSEIF (IST1.EQ.62) THEN
26841 c & ' CHASTA: unknown parton status flag (',
26842 c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26845 ID = IDHKK(JMOHKK(1,IDX))
26846 IF (ABS(ID).LE.4) THEN
26852 ELSEIF (ABS(ID).GE.1000) THEN
26858 ELSEIF (ID.EQ.21) THEN
26862 & ' CHASTA: inconsistent parton identity (',
26863 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26867 * parton 2 (target side)
26868 IF (IST2.EQ.21) THEN
26870 ELSEIF (IST2.EQ.22) THEN
26872 ELSEIF (IST2.EQ.31) THEN
26874 ELSEIF (IST2.EQ.32) THEN
26876 ELSEIF (IST2.EQ.41) THEN
26878 ELSEIF (IST2.EQ.42) THEN
26880 ELSEIF (IST2.EQ.51) THEN
26882 ELSEIF (IST2.EQ.52) THEN
26884 ELSEIF (IST2.EQ.61) THEN
26886 ELSEIF (IST2.EQ.62) THEN
26890 c & ' CHASTA: unknown parton status flag (',
26891 c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
26894 ID = IDHKK(JMOHKK(2,IDX))
26895 IF (ABS(ID).LE.4) THEN
26901 ELSEIF (ABS(ID).GE.1000) THEN
26907 ELSEIF (ID.EQ.21) THEN
26911 & ' CHASTA: inconsistent parton identity (',
26912 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26917 ITYPE = ICHTYP(ITYP1,ITYP2)
26918 IF (ITYPE.NE.0) THEN
26919 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
26920 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
26921 ICHCFG(IDX1,IDX2,ITYPE,2) =
26922 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
26925 IF (NCHAIN.GT.MAXCHN) THEN
26926 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
26930 IDXCHN(1,NCHAIN) = IDX
26931 IDXCHN(2,NCHAIN) = ITYPE
26934 & ' CHASTA: inconsistent chain at entry ',IDX
26940 * write statistics to output unit
26942 ELSEIF (MODE.EQ.1) THEN
26943 C *** Commented by Chiara
26944 C WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
26946 C WRITE(LOUT,'(/,2A)')
26947 C & ' -----------------------------------------',
26948 C & '------------------------------------'
26949 C WRITE(LOUT,'(2A)')
26950 C & ' p\\t 21 22 31 32 41',
26951 C & ' 42 51 52 61 62'
26952 C WRITE(LOUT,'(2A)')
26953 C & ' -----------------------------------------',
26954 C & '------------------------------------'
26958 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
26961 C *** Commented by Chiara
26962 c WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
26966 ISUM = ISUM+ICHCFG(I,J,K,1)
26968 C *** Commented by Chiara
26970 C & WRITE(LOUT,'(1X,A5,2X,10I7)')
26971 C & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
26973 C WRITE(LOUT,'(2A)')
26974 C & ' -----------------------------------------',
26975 C & '-------------------------------'
26979 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
26986 *===pohist=============================================================*
26989 CDECK ID>, PHO_PHIST
26990 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
26992 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
26995 PARAMETER ( LINP = 5 ,
26999 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27001 * Glauber formalism: cross sections
27002 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
27003 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
27004 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
27005 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
27006 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
27007 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
27008 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
27009 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
27010 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
27011 & BSLOPE,NEBINI,NQBINI
27014 IF (IMODE.EQ.10) THEN
27018 IF (ABS(IMODE).LT.1000) THEN
27019 * PHOJET-statistics
27020 C CALL POHISX(IMODE,WEIGHT)
27021 IF (IMODE.EQ.-1) THEN
27023 XSTOT(1,1,1) = WEIGHT
27025 IF (IMODE.EQ. 1) MODE = 2
27026 IF (IMODE.EQ.-2) MODE = 3
27027 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
27028 C IF (MODE.EQ.3) WRITE(LOUT,*)
27029 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
27030 CALL DT_HISTOG(MODE)
27031 CALL DT_USRHIS(MODE)
27033 * DTUNUC-statistics
27035 C IF (MODE.EQ.3) WRITE(LOUT,*)
27036 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
27037 CALL DT_HISTOG(MODE)
27038 CALL DT_USRHIS(MODE)
27044 *===swppho=============================================================*
27046 CDECK ID>, DT_SWPPHO
27047 SUBROUTINE DT_SWPPHO(ILAB)
27049 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
27052 PARAMETER ( LINP = 5 ,
27056 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27062 PARAMETER (NMXHKK=200000)
27064 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27065 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27066 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27067 * extended event history
27068 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27069 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27071 * flags for input different options
27072 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
27073 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
27074 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
27075 * properties of photon/lepton projectiles
27076 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
27079 C PARAMETER (NMXHEP=2000)
27080 C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27081 C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
27082 C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27083 C COMMON /PLASAV/ PLAB
27086 C standard particle data interface
27089 PARAMETER (NMXHEP=4000)
27091 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27092 DOUBLE PRECISION PHEP,VHEP
27093 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27094 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27096 C extension to standard particle data interface (PHOJET specific)
27097 INTEGER IMPART,IPHIST,ICOLOR
27098 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27100 C global event kinematics and particle IDs
27101 INTEGER IFPAP,IFPAB
27102 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27103 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27107 DATA LSTART /.TRUE./
27109 C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
27110 IF ((IFRAME.EQ.1).AND.LSTART) THEN
27114 IDP = IDT_ICIHAD(IFPAP(1))
27115 IDT = IDT_ICIHAD(IFPAP(2))
27117 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
27126 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
27128 IF (ISTHEP(I).EQ.1) THEN
27131 IDHKK(NHKK) = IDHEP(I)
27137 PHKK(K,NHKK) = PHEP(K,I)
27138 VHKK(K,NHKK) = ZERO
27139 WHKK(K,NHKK) = ZERO
27141 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
27142 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
27143 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
27144 PHKK(5,NHKK) = PHEP(5,I)
27148 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
27156 *===histog=============================================================*
27158 CDECK ID>, DT_HISTOG
27159 SUBROUTINE DT_HISTOG(MODE)
27161 ************************************************************************
27162 * This version dated 25.03.96 is written by S. Roesler *
27163 ************************************************************************
27165 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27168 PARAMETER ( LINP = 5 ,
27176 PARAMETER (NMXHKK=200000)
27178 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27179 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27180 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27181 * extended event history
27182 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27183 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27185 * event flag used for histograms
27186 COMMON /DTNORM/ ICEVT,IEVHKK
27187 * flags for activated histograms
27188 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
27193 *------------------------------------------------------------------
27197 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
27198 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
27201 *------------------------------------------------------------------
27202 * filling of histogram with event-record
27207 CALL DT_SWPFSP(I,LFSP,LRNL)
27209 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
27210 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
27212 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
27214 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
27217 *------------------------------------------------------------------
27220 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
27221 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
27226 *===swpfsp=============================================================*
27228 CDECK ID>, DT_SWPFSP
27229 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
27231 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27233 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27234 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
27236 & BOG =TWOPI/360.0D0)
27240 PARAMETER (NMXHKK=200000)
27242 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27243 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27244 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27245 * extended event history
27246 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27247 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27249 * particle properties (BAMJET index convention)
27251 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27252 & IICH(210),IIBAR(210),K1(210),K2(210)
27253 * Lorentz-parameters of the current interaction
27254 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27255 & UMO,PPCM,EPROJ,PPROJ
27256 * flags for input different options
27257 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
27258 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
27259 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
27261 INCLUDE './flukapro/(DIMPAR)'
27262 INCLUDE './flukapro/(PAREVT)'
27264 * temporary storage for one final state particle
27265 LOGICAL LFRAG,LGREY,LBLACK
27266 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
27267 & SINTHE,COSTHE,THETA,THECMS,
27268 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
27269 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
27270 & LFRAG,LGREY,LBLACK
27278 IF (LEVPRT) ISTRNL = 1001
27280 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
27284 IF (IDHKK(IDX).LT.80000) THEN
27286 IBARY = IIBAR(IDBJT)
27287 ICHAR = IICH(IDBJT)
27289 ELSEIF (IDHKK(IDX).EQ.80000) THEN
27292 ICHAR = IDXRES(IDX)
27293 AMASS = PHKK(5,IDX)
27295 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
27296 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
27297 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
27298 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
27299 IF (IDBJT.EQ.0) LFRAG = .TRUE.
27309 PTOT = SQRT(PT2+PZ**2)
27310 SINTHE = PT/MAX(PTOT,TINY14)
27311 COSTHE = PZ/MAX(PTOT,TINY14)
27312 IF (COSTHE.GT.ONE) THEN
27314 ELSEIF (COSTHE.LT.-ONE) THEN
27315 THETA = TWOPI/2.0D0
27317 THETA = ACOS(COSTHE)
27320 **sr 15.4.96 new E_t-definition
27321 IF (IBARY.GT.0) THEN
27323 ELSEIF (IBARY.LT.0) THEN
27324 ET = (EKIN+TWO*AMASS)*SINTHE
27329 XLAB = PZ/MAX(PPROJ,TINY14)
27330 C XLAB = PE/MAX(EPROJ,TINY14)
27331 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
27332 & *(ONE+AMASS/MAX(PE,TINY14)) ))
27335 IF (PMINUS.GT.TINY14) THEN
27336 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
27340 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
27341 ETA = -LOG(TAN(THETA/TWO))
27345 IF (IFRAME.EQ.1) THEN
27346 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
27347 PPLUS = EECMS+PZCMS
27348 PMINUS = EECMS-PZCMS
27349 IF ((PPLUS*PMINUS).GT.TINY14) THEN
27350 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
27354 PTOTCM = SQRT(PT2+PZCMS**2)
27355 COSTH = PZCMS/MAX(PTOTCM,TINY14)
27356 IF (COSTH.GT.ONE) THEN
27358 ELSEIF (COSTH.LT.-ONE) THEN
27359 THECMS = TWOPI/2.0D0
27361 THECMS = ACOS(COSTH)
27363 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
27364 ETACMS = -LOG(TAN(THECMS/TWO))
27368 XF = PZCMS/MAX(PPCM,TINY14)
27369 THECMS = THECMS/BOG
27380 * set flag for "grey/black"
27384 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
27385 IF (MULDEF.EQ.1) THEN
27387 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
27388 & (EK.LE.375.0D-3) ).OR.
27389 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
27390 & (EK.LE. 56.0D-3) ).OR.
27391 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
27392 & (EK.LE. 56.0D-3) ).OR.
27393 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
27394 & (EK.LE.198.0D-3) ).OR.
27395 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
27396 & (EK.LE.198.0D-3) ).OR.
27397 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
27398 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
27399 & (IDBJT.NE.16).AND.
27400 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
27402 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
27403 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
27404 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
27405 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
27406 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
27407 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
27408 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
27409 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
27413 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
27414 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
27417 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
27423 ICHAR = IDXRES(IDX)
27424 AMASS = PHKK(5,IDX)
27431 PTOT = SQRT(PT2+PZ**2)
27432 SINTHE = PT/MAX(PTOT,TINY14)
27433 COSTHE = PZ/MAX(PTOT,TINY14)
27434 IF (COSTHE.GT.ONE) THEN
27436 ELSEIF (COSTHE.LT.-ONE) THEN
27437 THETA = TWOPI/2.0D0
27439 THETA = ACOS(COSTHE)
27442 **sr 15.4.96 new E_t-definition
27446 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
27447 ETA = -LOG(TAN(THETA/TWO))
27459 *===himult=============================================================*
27461 CDECK ID>, DT_HIMULT
27462 SUBROUTINE DT_HIMULT(MODE)
27464 ************************************************************************
27465 * Tables of average energies/multiplicities. *
27466 * This version dated 30.08.2000 is written by S. Roesler *
27467 ************************************************************************
27469 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27472 PARAMETER ( LINP = 5 ,
27476 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27478 PARAMETER (SWMEXP=1.7D0)
27480 CHARACTER*8 ANAMEH(4)
27482 * particle properties (BAMJET index convention)
27484 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27485 & IICH(210),IIBAR(210),K1(210),K2(210)
27486 * temporary storage for one final state particle
27487 LOGICAL LFRAG,LGREY,LBLACK
27488 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
27489 & SINTHE,COSTHE,THETA,THECMS,
27490 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
27491 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
27492 & LFRAG,LGREY,LBLACK
27493 * event flag used for histograms
27494 COMMON /DTNORM/ ICEVT,IEVHKK
27495 * Lorentz-parameters of the current interaction
27496 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27497 & UMO,PPCM,EPROJ,PPROJ
27499 PARAMETER (NOPART=210)
27500 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
27501 & AVPT(4,NOPART),IAVPT(4,NOPART)
27502 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
27506 *------------------------------------------------------------------
27521 *------------------------------------------------------------------
27522 * filling of histogram with event-record
27524 IF (PE.LT.0.0D0) THEN
27525 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
27528 IF (.NOT.LFRAG) THEN
27530 IF (LGREY) IVEL = 3
27531 IF (LBLACK) IVEL = 4
27532 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
27533 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
27534 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
27535 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
27536 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
27537 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
27538 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
27539 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
27540 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
27541 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
27542 IF (IDBJT.LT.116) THEN
27543 * total energy, multiplicity
27544 AVE(1,30) = AVE(1,30) +PE
27545 AVE(IVEL,30) = AVE(IVEL,30)+PE
27546 AVPT(1,30) = AVPT(1,30) +PT
27547 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
27548 IAVPT(1,30) = IAVPT(1,30) +1
27549 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
27550 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
27551 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
27552 AVMULT(1,30) = AVMULT(1,30) +ONE
27553 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
27554 * charged energy, multiplicity
27555 IF (ICHAR.LT.0) THEN
27556 AVE(1,26) = AVE(1,26) +PE
27557 AVE(IVEL,26) = AVE(IVEL,26)+PE
27558 AVPT(1,26) = AVPT(1,26) +PT
27559 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
27560 IAVPT(1,26) = IAVPT(1,26) +1
27561 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
27562 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
27563 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
27564 AVMULT(1,26) = AVMULT(1,26) +ONE
27565 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
27567 IF (ICHAR.NE.0) THEN
27568 AVE(1,27) = AVE(1,27) +PE
27569 AVE(IVEL,27) = AVE(IVEL,27)+PE
27570 AVPT(1,27) = AVPT(1,27) +PT
27571 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
27572 IAVPT(1,27) = IAVPT(1,27) +1
27573 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
27574 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
27575 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
27576 AVMULT(1,27) = AVMULT(1,27) +ONE
27577 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
27584 *------------------------------------------------------------------
27588 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
27589 & 29X,'---------------------',/)
27590 PRINT*,' MULDEF = ',MULDEF
27591 IF (MULDEF.EQ.1) THEN
27592 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
27596 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
27597 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
27598 & ,F4.2,' black: beta < ',F4.2,/)
27600 WRITE(LOUT,3003) SWMEXP
27601 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
27602 & 13X,'| total fast',
27603 C & ' grey black K f(',F3.1,')',/,1X,
27604 & ' grey black <pt> f(',F3.1,')',/,1X,
27605 & '------------+--------------',
27606 & '-------------------------------------------------')
27609 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
27610 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
27611 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
27612 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
27615 WRITE(LOUT,3004) ANAME(I),I,
27616 & AVMULT(1,I),AVMULT(2,I),
27617 & AVMULT(3,I),AVMULT(4,I),
27618 C & AVE(1,I),AVSWM(1,I)
27619 & AVPT(1,I),AVSWM(1,I)
27620 ELSEIF (I.LE.119) THEN
27621 WRITE(LOUT,3004) ANAMEH(I-115),I,
27622 & AVMULT(1,I),AVMULT(2,I),
27623 & AVMULT(3,I),AVMULT(4,I),
27624 C & AVE(1,I),AVSWM(1,I)
27625 & AVPT(1,I),AVSWM(1,I)
27627 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
27630 C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
27631 C & AVMULT(3,27)+AVMULT(4,27)
27637 *===histat=============================================================*
27639 CDECK ID>, DT_HISTAT
27640 SUBROUTINE DT_HISTAT(IDX,MODE)
27642 ************************************************************************
27643 * This version dated 26.02.96 is written by S. Roesler *
27644 ************************************************************************
27646 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27649 PARAMETER ( LINP = 5 ,
27653 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27654 PARAMETER (NDIM=199)
27658 PARAMETER (NMXHKK=200000)
27660 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27661 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27662 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27663 * extended event history
27664 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27665 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27667 * particle properties (BAMJET index convention)
27669 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27670 & IICH(210),IIBAR(210),K1(210),K2(210)
27672 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27674 * Glauber formalism: cross sections
27675 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
27676 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
27677 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
27678 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
27679 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
27680 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
27681 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
27682 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
27683 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
27684 & BSLOPE,NEBINI,NQBINI
27685 * emulsion treatment
27686 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27688 * properties of interacting particles
27689 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
27690 * rejection counter
27691 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27692 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27693 & IREXCI(3),IRDIFF(2),IRINC
27694 * statistics: residual nuclei
27695 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
27696 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
27697 & NINCST(2,4),NINCEV(2),
27698 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
27699 & NRESPB(2),NRESCH(2),NRESEV(4),
27700 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
27702 * parameter for intranuclear cascade
27704 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
27706 INCLUDE './flukapro/(DIMPAR)'
27707 INCLUDE './flukapro/(PAREVT)'
27708 INCLUDE './flukapro/(FRBKCM)'
27709 INCLUDE './flukapro/(EVAPAR)'
27711 * temporary storage for one final state particle
27712 LOGICAL LFRAG,LGREY,LBLACK
27713 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
27714 & SINTHE,COSTHE,THETA,THECMS,
27715 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
27716 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
27717 & LFRAG,LGREY,LBLACK
27718 * event flag used for histograms
27719 COMMON /DTNORM/ ICEVT,IEVHKK
27720 * statistics: double-Pomeron exchange
27721 COMMON /DTFLG2/ INTFLG,IPOPO
27723 DIMENSION EMUSAM(NCOMPX)
27725 CHARACTER*13 CMSG(3)
27726 DATA CMSG /'not requested','not requested','not requested'/
27728 GOTO (1,2,3,4,5) MODE
27730 *------------------------------------------------------------------
27733 * emulsion treatment
27734 IF (NCOMPO.GT.0) THEN
27739 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
27760 IF (J.LE.2) NINCHR(I,J) = 0
27761 IF (J.LE.3) NINCCO(I,J) = 0
27762 IF (J.LE.4) NINCST(I,J) = 0
27771 **dble Po statistics.
27775 *------------------------------------------------------------------
27776 * filling of histogram with event-record
27778 IF (IST.EQ.-1) THEN
27779 IF (.NOT.LFRAG) THEN
27780 IF (IDPDG.EQ.2212) THEN
27781 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
27782 ELSEIF (IDPDG.EQ.2112) THEN
27783 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
27784 ELSEIF (IDPDG.EQ.22) THEN
27785 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
27786 ELSEIF (IDPDG.EQ.80000) THEN
27787 IF (IDBJT.EQ.116) THEN
27788 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
27789 ELSEIF (IDBJT.EQ.117) THEN
27790 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
27791 ELSEIF (IDBJT.EQ.118) THEN
27792 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
27793 ELSEIF (IDBJT.EQ.119) THEN
27794 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
27798 * heavy fragments (here: fission products only)
27799 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
27800 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
27801 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
27803 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
27804 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
27808 *------------------------------------------------------------------
27812 **dble Po statistics.
27813 C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
27814 C & '# evts. / # dble-Po. evts / s_in / s_popo :',
27815 C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
27817 * emulsion treatment
27818 IF (NCOMPO.GT.0) THEN
27820 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
27821 & 22X,'----------------------------',/,/,19X,
27822 & 'mass charge fraction',/,39X,
27823 & 'input treated',/)
27825 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
27826 & EMUSAM(I)/DBLE(ICEVT)
27827 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
27831 * i.n.c. statistics: output
27832 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
27833 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
27834 & 22X,'---------------------------------',/,/,1X,
27835 & 'no. of events for normalization: (accepted final events,',
27836 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
27837 & /,1X,'no. of rejected events due to intranuclear',
27838 & ' cascade',15X,I6,/)
27839 ICEV = MAX(ICEVT,1)
27841 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
27843 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
27844 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
27845 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
27846 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
27847 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
27848 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
27849 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
27850 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
27851 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
27852 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
27853 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
27854 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
27855 & /,1X,'maximum no. of generations treated (maximum allowed:'
27856 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
27857 & ' interactions in proj./ target (mean per evt1)',
27858 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
27859 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
27860 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
27861 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
27862 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
27863 & IREXCI(1)+IREXCI(2)+IREXCI(3)
27864 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
27865 & 'evaporation',/,22X,'-----------------------------',
27866 & '------------',/,/,1X,'no. of events for normal.: ',
27867 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
27868 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
27869 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
27872 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
27873 ICEV = MAX(NRESEV(2),1)
27875 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
27876 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
27877 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
27878 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
27879 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
27880 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
27881 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
27882 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
27883 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
27884 & 'proj. / target',/,/,8X,'total number of particles',15X,
27885 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
27886 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
27887 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
27888 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
27889 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
27891 * evaporation / fission / fragmentation statistics: output
27892 ICEV = MAX(NRESEV(2),1)
27893 ICEV1 = MAX(NRESEV(4),1)
27895 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
27897 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
27899 IF (IFISS.EQ.1) CMSG(1) = 'requested '
27900 IF (LFRMBK) CMSG(2) = 'requested '
27901 IF (LDEEXG) CMSG(3) = 'requested '
27904 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
27905 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
27906 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
27907 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
27908 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
27909 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
27910 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
27911 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
27912 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
27913 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
27914 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
27915 & 'deexcitation:',2X,A13,/,/,
27916 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
27917 & 'proj. / target',/,/,8X,'total number of evap. particles',
27918 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
27919 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
27920 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
27921 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
27922 & 'heavy fragments',25X,2F9.3,/)
27923 IF (IFISS.EQ.1) THEN
27924 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
27925 & NEVAFI(2,1),NEVAFI(2,2),
27926 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
27927 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
27928 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
27929 & 12X,'out of which fission occured',8X,2I9,/,
27930 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
27932 C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
27934 C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
27935 C & ' proj. / target',/)
27937 C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
27938 C WRITE(LOUT,3009) I,
27939 C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
27940 C3009 FORMAT(38X,I3,3X,2E12.3)
27944 C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
27945 C & ' proj. / target',/)
27947 C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
27948 C WRITE(LOUT,3011) I,
27949 C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
27950 C3011 FORMAT(38X,I3,3X,2E12.3)
27957 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
27958 & 'Evaporation: not requested',/)
27962 *------------------------------------------------------------------
27963 * filling of histogram with event-record
27965 * emulsion treatment
27966 IF (NCOMPO.GT.0) THEN
27968 IF (IT.EQ.IEMUMA(I)) THEN
27969 EMUSAM(I) = EMUSAM(I)+ONE
27973 NINCGE = NINCGE+MAXGEN
27975 **dble Po statistics.
27976 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
27979 *------------------------------------------------------------------
27980 * filling of histogram with event-record
27982 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
27983 IB = IIBAR(IDBAM(IDX))
27984 IC = IICH(IDBAM(IDX))
27986 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
27987 NINCST(J,1) = NINCST(J,1)+1
27988 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
27989 NINCST(J,2) = NINCST(J,2)+1
27990 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
27991 NINCST(J,3) = NINCST(J,3)+1
27992 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
27993 NINCST(J,4) = NINCST(J,4)+1
27995 ELSEIF (ISTHKK(IDX).EQ.17) THEN
27996 NINCWO(1) = NINCWO(1)+1
27997 ELSEIF (ISTHKK(IDX).EQ.18) THEN
27998 NINCWO(2) = NINCWO(2)+1
27999 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
28003 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
28004 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
28006 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
28012 *===newhgr=============================================================*
28014 CDECK ID>, DT_NEWHGR
28015 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
28017 ************************************************************************
28019 * Histogram initialization. *
28021 * input: XLIM1/XLIM2 lower/upper edge of histogram-window *
28023 * IBIN > 0 number of bins in equidistant lin. binning *
28024 * = -1 reset histograms *
28025 * < -1 |IBIN| number of bins in equidistant log. *
28026 * binning or log. binning in user def. struc. *
28027 * XLIMB(*) user defined bin structure *
28029 * The bin structure is sensitive to *
28030 * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
28031 * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
28032 * XLIMB, IBIN if XLIM3 < 0 *
28035 * output: IREFN histogram index *
28036 * (= -1 for inconsistent histogr. request) *
28038 * This subroutine is based on a original version by R. Engel. *
28039 * This version dated 22.4.95 is written by S. Roesler. *
28040 ************************************************************************
28042 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28045 PARAMETER ( LINP = 5 ,
28051 PARAMETER (ZERO = 0.0D0,
28058 PARAMETER (NHIS=150, NDIM=250)
28060 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28061 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28062 * auxiliary common for histograms
28063 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
28065 DATA LSTART /.TRUE./
28067 * reset histogram counter
28068 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
28070 IF (IBIN.EQ.-1) RETURN
28075 * check for maximum number of allowed histograms
28076 IF (IHIS.GT.NHIS) THEN
28077 WRITE(LOUT,1003) IHIS,NHIS,IHIS
28078 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
28079 & I4,') exceeds array size (',I4,')',/,21X,
28080 & 'histogram',I3,' skipped!')
28085 IBINS(IHIS) = ABS(IBIN)
28086 * check requested number of bins
28087 IF (IBINS(IHIS).GE.NDIM) THEN
28088 WRITE(LOUT,1000) IBIN,NDIM,NDIM
28089 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
28090 & I3,') exceeds array size (',I3,')',/,21X,
28091 & 'and will be reset to ',I3)
28094 IF (IBINS(IHIS).EQ.0) THEN
28095 WRITE(LOUT,1001) IBIN,IHIS
28096 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
28097 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
28101 * initialize arrays
28104 HIST(K,IHIS,I) = ZERO
28105 HIST(K+3,IHIS,I) = ZERO
28106 TMPHIS(K,IHIS,I) = ZERO
28108 HIST(7,IHIS,I) = ZERO
28110 DENTRY(1,IHIS)= ZERO
28111 DENTRY(2,IHIS)= ZERO
28113 UNDERF(IHIS) = ZERO
28114 TMPUFL(IHIS) = ZERO
28115 TMPOFL(IHIS) = ZERO
28117 * bin str. sensitive to lower edge, bin size, and numb. of bins
28118 IF (XLIM3.GT.ZERO) THEN
28119 DO 3 K=1,IBINS(IHIS)+1
28120 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
28123 * bin str. sensitive to lower/upper edge and numb. of bins
28124 ELSEIF (XLIM3.EQ.ZERO) THEN
28126 IF (IBIN.GT.0) THEN
28129 IF (XLIM2.LE.XLIM1) THEN
28130 WRITE(LOUT,1002) XLIM1,XLIM2
28131 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
28132 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
28136 ELSEIF (IBIN.LT.-1) THEN
28137 * logarithmic binning
28138 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
28139 WRITE(LOUT,1004) XLIM1,XLIM2
28140 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
28141 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
28144 IF (XLIM2.LE.XLIM1) THEN
28145 WRITE(LOUT,1005) XLIM1,XLIM2
28146 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
28147 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
28150 XLOW = LOG10(XLIM1)
28154 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
28155 DO 4 K=1,IBINS(IHIS)+1
28156 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
28159 * user defined bin structure
28160 DO 5 K=1,IBINS(IHIS)+1
28161 IF (IBIN.GT.0) THEN
28162 HIST(1,IHIS,K) = XLIMB(K)
28164 ELSEIF (IBIN.LT.-1) THEN
28165 HIST(1,IHIS,K) = LOG10(XLIMB(K))
28171 * histogram accepted
28181 *===filhgr=============================================================*
28183 CDECK ID>, DT_FILHGR
28184 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
28186 ************************************************************************
28188 * Scoring for histogram IHIS. *
28190 * This subroutine is based on a original version by R. Engel. *
28191 * This version dated 23.4.95 is written by S. Roesler. *
28192 ************************************************************************
28194 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28197 PARAMETER ( LINP = 5 ,
28201 PARAMETER (ZERO = 0.0D0,
28207 PARAMETER (NHIS=150, NDIM=250)
28209 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28210 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28211 * auxiliary common for histograms
28212 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
28219 * dump content of temorary arrays into histograms
28220 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
28221 CALL DT_EVTHIS(IDUM)
28225 * check histogram index
28226 IF (IHIS.EQ.-1) RETURN
28227 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
28228 C WRITE(LOUT,1000) IHIS,IHISL
28229 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
28230 & ' out of range (1..',I3,')')
28234 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
28235 * bin structure not explicitly given
28236 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
28237 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
28238 IF (X.LT.HIST(1,IHIS,1)) THEN
28241 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
28244 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
28245 * user defined bin structure
28246 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
28247 IF (X.LT.HIST(1,IHIS,1)) THEN
28249 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
28252 * binary sort algorithm
28254 KMAX = IBINS(IHIS)+1
28256 IF ((KMAX-KMIN).EQ.1) GOTO 2
28258 IF (X.LE.HIST(1,IHIS,KK)) THEN
28270 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
28276 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
28277 ELSEIF (I1.LE.IBINS(IHIS)) THEN
28278 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
28279 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
28280 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
28282 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
28284 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
28286 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
28292 *===evthis=============================================================*
28294 CDECK ID>, DT_EVTHIS
28295 SUBROUTINE DT_EVTHIS(NEVT)
28297 ************************************************************************
28298 * Dump content of temorary histograms into /DTHIS1/. This subroutine *
28299 * is called after each event and for the last event before any call *
28301 * NEVT number of events dumped, this is only needed to *
28302 * get the normalization after the last event *
28303 * This version dated 23.4.95 is written by S. Roesler. *
28304 ************************************************************************
28306 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28309 PARAMETER ( LINP = 5 ,
28315 PARAMETER (ZERO = 0.0D0,
28321 PARAMETER (NHIS=150, NDIM=250)
28323 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28324 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28325 * auxiliary common for histograms
28326 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
28336 IF (TMPHIS(1,I,J).GT.ZERO) THEN
28338 HIST(2,I,J) = HIST(2,I,J)+ONE
28339 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
28340 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
28341 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
28342 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
28343 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
28344 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
28345 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
28346 TMPHIS(1,I,J) = ZERO
28347 TMPHIS(2,I,J) = ZERO
28348 TMPHIS(3,I,J) = ZERO
28352 IF (TMPUFL(I).GT.ZERO) THEN
28353 UNDERF(I) = UNDERF(I)+ONE
28355 ELSEIF (TMPOFL(I).GT.ZERO) THEN
28356 OVERF(I) = OVERF(I)+ONE
28360 DENTRY(1,I) = DENTRY(1,I)+ONE
28367 *===outhgr=============================================================*
28369 CDECK ID>, DT_OUTHGR
28370 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
28371 & ILOGY,INORM,NMODE)
28373 ************************************************************************
28375 * Plot histogram(s) to standard output unit *
28377 * I1..6 indices of histograms to be plotted *
28378 * CHEAD,IHEAD header string,integer *
28379 * NEVTS number of events *
28380 * FAC scaling factor *
28381 * ILOGY = 1 logarithmic y-axis *
28382 * INORM normalization *
28383 * = 0 no further normalization (FAC is obsolete) *
28384 * = 1 per event and bin width *
28385 * = 2 per entry and bin width *
28386 * = 3 per bin entry *
28387 * = 4 per event and "bin width" x1^2...x2^2 *
28388 * = 5 per event and "log. bin width" ln x1..ln x2 *
28390 * MODE = 0 no output but normalization applied *
28391 * = 1 all valid histograms separately (small frame) *
28392 * all valid histograms separately (small frame) *
28393 * = -1 and tables as histograms *
28394 * = 2 all valid histograms (one plot, wide frame) *
28395 * all valid histograms (one plot, wide frame) *
28396 * = -2 and tables as histograms *
28399 * Note: All histograms to be plotted with one call to this *
28400 * subroutine and |MODE|=2 must have the same bin structure! *
28401 * There is no test included ensuring this fact. *
28403 * This version dated 23.4.95 is written by S. Roesler. *
28404 ************************************************************************
28406 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28409 PARAMETER ( LINP = 5 ,
28415 PARAMETER (ZERO = 0.0D0,
28427 PARAMETER (NHIS=150, NDIM=250)
28429 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28430 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28432 PARAMETER (NDIM2 = 2*NDIM)
28433 DIMENSION XX(NDIM2),YY(NDIM2)
28435 PARAMETER (NHISTO = 6)
28436 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
28439 CHARACTER*43 CNORM(0:8)
28440 DATA CNORM /'no further normalization ',
28441 & 'per event and bin width ',
28442 & 'per entry1 and bin width ',
28443 & 'per bin entry ',
28444 & 'per event and "bin width" x1^2...x2^2 ',
28445 & 'per event and "log. bin width" ln x1..ln x2',
28447 & 'per bin entry1 ',
28448 & 'per entry2 and bin width '/
28459 * initialization if "wide frame" is requested
28460 IF (ABS(MODE).EQ.2) THEN
28470 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
28472 * check histogram indices
28475 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
28476 IF (ISWI(IDX1(I)).NE.0) THEN
28477 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
28479 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
28480 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
28481 & ' histogram ',I3,/,21X,'underflows:',F10.0,
28482 & ' overflows: ',F10.0)
28492 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
28496 * check normalization request
28497 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
28498 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
28499 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
28500 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
28501 WRITE(LOUT,1002) NEVTS,INORM,FAC
28502 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
28503 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
28508 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
28510 * apply normalization
28515 IF (ISWI(I).EQ.1) THEN
28516 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
28517 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
28518 & ' to',2X,E10.4,',',2X,I3,' bins')
28519 ELSEIF (ISWI(I).EQ.2) THEN
28520 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
28522 1007 FORMAT(1X,'user defined bin structure')
28523 ELSEIF (ISWI(I).EQ.3) THEN
28525 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
28526 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
28527 & ' to',2X,E10.4,',',2X,I3,' bins')
28528 ELSEIF (ISWI(I).EQ.4) THEN
28530 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
28533 WRITE(LOUT,1008) ISWI(I)
28534 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
28536 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
28537 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
28538 & ' overfl.:',F8.0)
28539 WRITE(LOUT,1009) CNORM(INORM)
28540 1009 FORMAT(1X,'normalization: ',A,/)
28543 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
28546 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
28547 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
28548 1006 FORMAT(1X,5E11.3)
28551 XX(II-1) = HIST(1,I,K)
28552 XX(II) = HIST(1,I,K+1)
28557 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
28558 & XX1(K,N) = LOG10(XMEAN)
28563 IF (ABS(MODE).EQ.1) THEN
28565 WRITE(LOUT,'(/,1X,A)') 'Preview:'
28566 IF(ILOGY.EQ.1) THEN
28567 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
28569 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
28576 IF (ABS(MODE).EQ.2) THEN
28577 WRITE(LOUT,'(/,1X,A)') 'Preview:'
28578 NSIZE = NDIM*NHISTO
28579 DXLOW = HIST(1,IDX(1),1)
28580 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
28585 IF (YY1(J,I).LT.YLOW) THEN
28586 IF (ILOGY.EQ.1) THEN
28587 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
28592 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
28595 DY = (YHI-YLOW)/DBLE(NDIM)
28596 IF (DY.LE.ZERO) THEN
28597 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
28598 & 'OUTHGR: warning! zero bin width for histograms ',
28599 & IDX,': ',YLOW,YHI
28602 IF (ILOGY.EQ.1) THEN
28604 DY = (LOG10(YHI)-YLOW)/100.0D0
28607 IF (YY1(J,I).LE.ZERO) THEN
28610 YY1(J,I) = LOG10(YY1(J,I))
28615 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
28621 *===getbin=============================================================*
28623 CDECK ID>, DT_GETBIN
28624 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
28625 & XMEAN,YMEAN,YERR)
28627 ************************************************************************
28628 * This version dated 23.4.95 is written by S. Roesler. *
28629 ************************************************************************
28631 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28634 PARAMETER ( LINP = 5 ,
28638 PARAMETER (ZERO = 0.0D0,
28640 & TINY35 = 1.0D-35)
28644 PARAMETER (NHIS=150, NDIM=250)
28646 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28647 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28649 XLOW = HIST(1,IHIS,IBIN)
28650 XHI = HIST(1,IHIS,IBIN+1)
28651 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
28655 IF (NORM.EQ.2) THEN
28657 NEVT = INT(DENTRY(1,IHIS))
28658 ELSEIF (NORM.EQ.3) THEN
28660 NEVT = INT(HIST(2,IHIS,IBIN))
28661 ELSEIF (NORM.EQ.4) THEN
28662 DX = XHI**2-XLOW**2
28664 ELSEIF (NORM.EQ.5) THEN
28665 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
28667 ELSEIF (NORM.EQ.6) THEN
28670 ELSEIF (NORM.EQ.7) THEN
28672 NEVT = INT(HIST(7,IHIS,IBIN))
28673 ELSEIF (NORM.EQ.8) THEN
28675 NEVT = INT(DENTRY(2,IHIS))
28680 IF (ABS(DX).LT.TINY35) DX = ONE
28682 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
28683 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
28684 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
28685 YSUM = HIST(5,IHIS,IBIN)
28686 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
28687 C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
28688 XMEAN = HIST(3,IHIS,IBIN)/YSUM
28689 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
28694 *===joihis=============================================================*
28696 CDECK ID>, DT_JOIHIS
28697 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
28699 ************************************************************************
28701 * Operation on histograms. *
28703 * input: IH1,IH2 histogram indices to be joined *
28704 * COPER character defining the requested operation, *
28705 * i.e. '+', '-', '*', '/' *
28706 * FAC1,FAC2 factors for joining, i.e. *
28707 * FAC1*histo1 COPER FAC2*histo2 *
28709 * This version dated 23.4.95 is written by S. Roesler. *
28710 ************************************************************************
28712 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28715 PARAMETER ( LINP = 5 ,
28721 PARAMETER (ZERO = 0.0D0,
28730 PARAMETER (NHIS=150, NDIM=250)
28732 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28733 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28735 PARAMETER (NDIM2 = 2*NDIM)
28736 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
28738 CHARACTER*43 CNORM(0:6)
28739 DATA CNORM /'no further normalization ',
28740 & 'per event and bin width ',
28741 & 'per entry and bin width ',
28742 & 'per bin entry ',
28743 & 'per event and "bin width" x1^2...x2^2 ',
28744 & 'per event and "log. bin width" ln x1..ln x2',
28747 * check histogram indices
28748 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
28749 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
28750 WRITE(LOUT,1000) IH1,IH2,IHISL
28751 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
28752 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
28756 * check bin structure of histograms to be joined
28757 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
28758 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
28759 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
28760 & ' and ',I3,' failed',/,21X,
28761 & 'due to different numbers of bins (',I3,',',I3,')')
28764 DO 1 K=1,IBINS(IH1)+1
28765 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
28766 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
28767 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
28768 & ' and ',I3,' failed at bin edge ',I3,/,21X,
28769 & 'X1,X2 = ',2E11.4)
28774 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
28775 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
28776 & 'operation ',A,/,11X,'and factors ',2E11.4)
28777 WRITE(LOUT,1004) CNORM(NORM)
28778 1004 FORMAT(1X,'normalization: ',A,/)
28780 DO 2 K=1,IBINS(IH1)
28781 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
28782 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
28785 XMEAN = OHALF*(XMEAN1+XMEAN2)
28786 IF (COPER.EQ.'+') THEN
28787 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
28788 ELSEIF (COPER.EQ.'*') THEN
28789 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
28790 ELSEIF (COPER.EQ.'/') THEN
28791 IF (YMEAN2.EQ.ZERO) THEN
28794 IF (FAC2.EQ.ZERO) FAC2 = ONE
28795 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
28800 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
28801 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
28802 1006 FORMAT(1X,5E11.3)
28805 XX(II-1) = HIST(1,IH1,K)
28806 XX(II) = HIST(1,IH1,K+1)
28811 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
28816 IF (ABS(MODE).EQ.1) THEN
28817 IBIN2 = 2*IBINS(IH1)
28818 WRITE(LOUT,'(/,1X,A)') 'Preview:'
28819 IF(ILOGY.EQ.1) THEN
28820 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
28822 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
28827 IF (ABS(MODE).EQ.2) THEN
28828 WRITE(LOUT,'(/,1X,A)') 'Preview:'
28830 DXLOW = HIST(1,IH1,1)
28831 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
28835 IF (YY1(I).LT.YLOW) THEN
28836 IF (ILOGY.EQ.1) THEN
28837 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
28842 IF (YY1(I).GT.YHI) YHI = YY1(I)
28844 DY = (YHI-YLOW)/DBLE(NDIM)
28845 IF (DY.LE.ZERO) THEN
28846 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
28847 & 'JOIHIS: warning! zero bin width for histograms ',
28848 & IH1,IH2,': ',YLOW,YHI
28851 IF (ILOGY.EQ.1) THEN
28853 DY = (LOG10(YHI)-YLOW)/100.0D0
28855 IF (YY1(I).LE.ZERO) THEN
28858 YY1(I) = LOG10(YY1(I))
28862 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
28868 WRITE(LOUT,1005) COPER
28869 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
28875 *===qgraph=============================================================*
28877 CDECK ID>, DT_XGRAPH
28878 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
28879 C***********************************************************************
28881 C calculate quasi graphic picture with 25 lines and 79 columns
28882 C ranges will be chosen automatically
28884 C input N dimension of input fields
28885 C IARG number of curves (fields) to plot
28890 C This subroutine is written by R. Engel.
28891 C***********************************************************************
28892 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28895 PARAMETER ( LINP = 5 ,
28900 DIMENSION X(N),Y1(N),Y2(N)
28901 PARAMETER (EPS=1.D-30)
28902 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
28904 CHARACTER COL(0:149,0:49)
28906 DATA SYMB /'0','e','z','#','x'/
28910 C*** automatic range fitting
28915 XMAX=MAX(X(I),XMAX)
28916 XMIN=MIN(X(I),XMIN)
28918 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
28921 DO 1100 K=0,IZEIL-1
28923 IF (ITEST.EQ.IYRAST) THEN
28924 DO 1010 L=1,ISPALT-1
28929 DO 1020 L=0,ISPALT-1,IXRAST
28933 DO 1030 L=1,ISPALT-1
28936 DO 1040 L=0,ISPALT-1,IXRAST
28948 YMAX=MAX(Y1(I),YMAX)
28949 YMIN=MIN(Y1(I),YMIN)
28953 YMAX=MAX(Y2(I),YMAX)
28954 YMIN=MIN(Y2(I),YMIN)
28957 YMAX=(YMAX-YMIN)/40.0D0+YMAX
28958 YMIN=YMIN-(YMAX-YMIN)/40.0D0
28959 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
28960 IF(YZOOM.LT.EPS) THEN
28961 WRITE(LOUT,'(1X,A)')
28962 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
28971 L=NINT((X(K)-XMIN)/XZOOM)
28972 I=NINT((YMAX-Y1(K))/YZOOM)
28973 IF(ILAST.GE.0) THEN
28976 DO 55 II=0,LD,SIGN(1,LD)
28977 DO 66 KK=0,ID,SIGN(1,ID)
28978 COL(II+LLAST,KK+ILAST)=SYMB(1)
28993 L=NINT((X(K)-XMIN)/XZOOM)
28994 I=NINT((YMAX-Y2(K))/YZOOM)
29001 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29003 C*** write range of X
29005 XZOOM = (XMAX-XMIN)/DBLE(7)
29006 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
29008 DO 1300 K=0,IZEIL-1
29009 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
29010 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
29011 110 FORMAT(1X,1PE9.2,70A1)
29014 C*** write range of X
29016 XZOOM = (XMAX-XMIN)/DBLE(7)
29017 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
29018 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29019 120 FORMAT(6X,7(1PE10.3))
29022 *===qglogy=============================================================*
29024 CDECK ID>, DT_XGLOGY
29025 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
29026 C***********************************************************************
29028 C calculate quasi graphic picture with 25 lines and 79 columns
29029 C logarithmic y axis
29030 C ranges will be chosen automatically
29032 C input N dimension of input fields
29033 C IARG number of curves (fields) to plot
29038 C This subroutine is written by R. Engel.
29039 C***********************************************************************
29041 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29044 PARAMETER ( LINP = 5 ,
29048 DIMENSION X(N),Y1(N),Y2(N)
29049 PARAMETER (EPS=1.D-30)
29050 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
29052 CHARACTER COL(0:149,0:49)
29053 PARAMETER (DEPS = 1.D-10)
29055 DATA SYMB /'0','e','z','#','x'/
29059 C*** automatic range fitting
29064 XMAX=MAX(X(I),XMAX)
29065 XMIN=MIN(X(I),XMIN)
29067 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
29070 DO 1100 K=0,IZEIL-1
29072 IF (ITEST.EQ.IYRAST) THEN
29073 DO 1010 L=1,ISPALT-1
29078 DO 1020 L=0,ISPALT-1,IXRAST
29082 DO 1030 L=1,ISPALT-1
29085 DO 1040 L=0,ISPALT-1,IXRAST
29095 YMIN=MAX(Y1(1),EPS)
29097 YMAX =MAX(Y1(I),YMAX)
29098 IF(Y1(I).GT.EPS) THEN
29099 IF(YMIN.EQ.EPS) THEN
29102 YMIN = MIN(Y1(I),YMIN)
29108 YMAX=MAX(Y2(I),YMAX)
29109 IF(Y2(I).GT.EPS) THEN
29110 IF(YMIN.EQ.EPS) THEN
29113 YMIN = MIN(Y2(I),YMIN)
29120 Y1(I) = MAX(Y1(I),YMIN)
29124 Y2(I) = MAX(Y2(I),YMIN)
29128 IF(YMAX.LE.YMIN) THEN
29129 WRITE(LOUT,'(/1X,A,2E12.3,/)')
29130 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
29131 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
29135 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
29136 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
29137 YZOOM=(YMA-YMI)/DBLE(IZEIL)
29138 IF(YZOOM.LT.EPS) THEN
29139 WRITE(LOUT,'(1X,A)')
29140 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
29149 L=NINT((X(K)-XMIN)/XZOOM)
29150 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
29151 IF(ILAST.GE.0) THEN
29154 DO 55 II=0,LD,SIGN(1,LD)
29155 DO 66 KK=0,ID,SIGN(1,ID)
29156 COL(II+LLAST,KK+ILAST)=SYMB(1)
29171 L=NINT((X(K)-XMIN)/XZOOM)
29172 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
29179 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
29180 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29182 C*** write range of X
29184 XZOOM1 = (XMAX-XMIN)/DBLE(7)
29185 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
29187 DO 1300 K=0,IZEIL-1
29188 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
29189 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
29190 110 FORMAT(1X,1PE9.2,70A1)
29193 C*** write range of X
29195 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
29196 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29197 120 FORMAT(6X,7(1PE10.3))
29201 *===plot===============================================================*
29203 CDECK ID>, DT_SRPLOT
29204 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
29206 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29209 PARAMETER ( LINP = 5 ,
29215 * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
29216 * This is a subroutine of fluka to plot Y across the page
29217 * as a function of X down the page. Up to 37 curves can be
29218 * plotted in the same picture with different plotting characters.
29219 * Output of first 10 overprinted characters addad by FB 88
29220 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
29223 * X = array containing the values of X
29224 * Y = array containing the values of Y
29225 * N = number of values in X and in Y
29226 * can exceed the fixed number of lines
29227 * M = number of different curves X,Y are containing
29228 * MM = number of points in each curve i.e. N=M*MM
29229 * XO = smallest value of X to be plotted
29230 * DX = increment of X between subsequent lines
29231 * YO = smallest value of Y to be plotted
29232 * DY = increment of Y between subsequent character spaces
29234 * other variables used inside:
29235 * XX = numbers along the X-coordinate axis
29236 * YY = numbers along the Y-coordinate axis
29237 * LL = ten lines temporary storage for the plot
29238 * L = character set used to plot different curves
29239 * LOV = memorizes overprinted symbols
29240 * the first 10 overprinted symbols are printed on
29241 * the end of the line to avoid ambiguities
29242 * (added by FB as considered quite helpful)
29244 *********************************************************************
29246 DIMENSION XX(61),YY(61),LL(101,10)
29247 DIMENSION X(N),Y(N),L(40),LOV(40,10)
29249 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
29250 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
29251 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
29252 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
29261 20 YY(I)=YO+10.0D0*AI*DY
29262 WRITE(LOUT, 500) (YY(I),I=1,11)
29284 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
29285 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
29287 * changed Sept.88 by FB to avoid INTEGER OVERFLOW
29288 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
29289 + . AIY .LT. 102.D0) THEN
29292 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
29294 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
29305 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
29306 & (LOV(J,I),J=1,10)
29312 WRITE(LOUT, 500) (YY(I),I=1,11)
29315 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
29316 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
29317 520 FORMAT(20X,10('1---------'),'1')
29320 *===defset=============================================================*
29322 CDECK ID>, DT_DEFSET
29323 BLOCK DATA DT_DEFSET
29325 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29328 * flags for input different options
29329 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
29330 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
29331 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
29333 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29335 * emulsion treatment
29336 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29340 DATA IFRAG / 2, 1 /
29344 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
29345 DATA LEMCCK / .FALSE. /
29346 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
29347 & .TRUE.,.TRUE.,.TRUE./
29348 DATA LSEADI / .TRUE. /
29349 DATA LEVAPO / .TRUE. /
29351 * Introduced by Chiara -> Forcing CMS-system
29352 * DATA IFRAME / 2 /
29356 DATA EMUFRA / NCOMPX*0.0D0 /
29357 DATA IEMUMA / NCOMPX*1 /
29358 DATA IEMUCH / NCOMPX*1 /
29365 *===hadprp=============================================================*
29367 CDECK ID>, DT_HADPRP
29368 BLOCK DATA DT_HADPRP
29370 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29373 * auxiliary common for reggeon exchange (DTUNUC 1.x)
29374 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
29375 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
29376 & IQTCHR(-6:6),MQUARK(3,39)
29377 * hadron index conversion (BAMJET <--> PDG)
29378 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
29379 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
29381 * names of hadrons used in input-cards
29383 COMMON /DTPAIN/ BTYPE(30)
29386 *----------------------------------------------------------------------*
29388 * Quark content of particles: *
29389 * index quark el. charge bar. charge isospin isospin3 *
29390 * 1 = u 2/3 1/3 1/2 1/2 *
29391 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
29392 * 2 = d -1/3 1/3 1/2 -1/2 *
29393 * -2 = dbar 1/3 -1/3 1/2 1/2 *
29394 * 3 = s -1/3 1/3 0 0 *
29395 * -3 = sbar 1/3 -1/3 0 0 *
29396 * 4 = c 2/3 1/3 0 0 *
29397 * -4 = cbar -2/3 -1/3 0 0 *
29398 * 5 = b -1/3 1/3 0 0 *
29399 * -5 = bbar 1/3 -1/3 0 0 *
29400 * 6 = t 2/3 1/3 0 0 *
29401 * -6 = tbar -2/3 -1/3 0 0 *
29403 * Mquark = particle quark composition (Paprop numbering) *
29404 * Iqechr = electric charge ( in 1/3 unit ) *
29405 * Iqbchr = baryonic charge ( in 1/3 unit ) *
29406 * Iqichr = isospin ( in 1/2 unit ), z component *
29407 * Iqschr = strangeness *
29409 * Iquchr = beauty *
29410 * Iqtchr = ...... *
29412 *----------------------------------------------------------------------*
29413 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
29414 DATA IQBCHR / 6*-1, 0, 6*1 /
29415 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
29416 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
29417 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
29418 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
29419 DATA IQTCHR / -1, 11*0, 1 /
29421 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29422 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
29423 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
29424 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
29425 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
29426 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29427 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
29428 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
29431 * (renamed) (HAdron InDex COnversion)
29432 * translation table version filled up by r.e. 25.01.94 *
29434 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
29435 &13,130,211,-211,321, -321,3122,-3122,310,3112,
29436 &3222,3212,111,311,-311, 0,0,0,0,0,
29437 &221,213,113,-213,223, 323,313,-323,-313,10323,
29438 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
29439 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
29440 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
29441 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
29443 &4*99999,331, 333,3322,3312,-3222,-3212,
29444 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
29445 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
29446 &-431,441,423,413,-413, -423,433,-433,20443,443,
29447 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
29448 &4212,4112,3*99999, 3*99999,-4122,-4232,
29449 &-4132,-4222,-4212,-4112,99999, 5*99999,
29452 &5*99999 , 20211,20111,-20211,99999,20321,
29453 &-20321,20311,-20311,7*99999 ,
29454 &7*99999,12212,12112,99999/
29457 * (HAdron InDex COnversion)
29458 DATA (IPDG2(1,K),K=1,7)
29459 & / -11, -12, -13, -15, -16, -14, 0/
29460 DATA (IBAM2(1,K),K=1,7)
29461 & / 4, 6, 10, 131, 134, 136, 0/
29462 DATA (IPDG2(2,K),K=1,7)
29463 & / 11, 12, 22, 13, 15, 16, 14/
29464 DATA (IBAM2(2,K),K=1,7)
29465 & / 3, 5, 7, 11, 132, 133, 135/
29466 DATA (IPDG3(1,K),K=1,22)
29467 & / -211, -321, -311, -213, -323, -313, -411, -421,
29468 & -431, -413, -423, -433, 0, 0, 0, 0,
29469 & 0, 0, 0, 0, 0, 0/
29470 DATA (IBAM3(1,K),K=1,22)
29471 & / 14, 16, 25, 34, 38, 39, 118, 119,
29472 & 121, 125, 126, 128, 0, 0, 0, 0,
29473 & 0, 0, 0, 0, 0, 0/
29474 DATA (IPDG3(2,K),K=1,22)
29475 & / 130, 211, 321, 310, 111, 311, 221, 213,
29476 & 113, 223, 323, 313, 331, 333, 421, 411,
29477 & 431, 441, 423, 413, 433, 443/
29478 DATA (IBAM3(2,K),K=1,22)
29479 & / 12, 13, 15, 19, 23, 24, 31, 32,
29480 & 33, 35, 36, 37, 95, 96, 116, 117,
29481 & 120, 122, 123, 124, 127, 130/
29482 DATA (IPDG4(1,K),K=1,29)
29483 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
29484 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
29485 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
29486 & -4212, -4112, 0, 0, 0/
29487 DATA (IBAM4(1,K),K=1,29)
29488 & / 2, 9, 18, 67, 68, 69, 70, 75,
29489 & 76, 99, 100, 101, 102, 103, 110, 111,
29490 & 112, 113, 114, 115, 149, 150, 151, 152,
29491 & 153, 154, 0, 0, 0/
29492 DATA (IPDG4(2,K),K=1,29)
29493 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
29494 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
29495 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
29496 & 4232, 4132, 4222, 4212, 4112/
29497 DATA (IBAM4(2,K),K=1,29)
29498 & / 1, 8, 17, 20, 21, 22, 48, 49,
29499 & 50, 51, 52, 53, 54, 55, 56, 97,
29500 & 98, 104, 105, 106, 107, 108, 109, 137,
29501 & 138, 139, 140, 141, 142/
29502 DATA (IPDG5(1,K),K=1,19)
29503 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
29504 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
29506 DATA (IBAM5(1,K),K=1,19)
29507 & / 42, 43, 46, 47, 71, 72, 73, 74,
29508 & 188, 191, 193, 0, 0, 0, 0, 0,
29510 DATA (IPDG5(2,K),K=1,19)
29511 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
29512 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
29513 & 20311, 12212, 12112/
29514 DATA (IBAM5(2,K),K=1,19)
29515 & / 40, 41, 44, 45, 57, 58, 59, 60,
29516 & 63, 64, 65, 66, 129, 186, 187, 190,
29520 * internal particle names
29521 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
29522 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
29523 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
29524 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
29525 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
29526 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
29531 *===blkd46=============================================================*
29533 CDECK ID>, DT_BLKD46
29534 BLOCK DATA DT_BLKD46
29536 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29539 PARAMETER ( AMELCT = 0.51099906 D-03 )
29540 PARAMETER ( AMMUON = 0.105658389 D+00 )
29542 * particle properties (BAMJET index convention)
29544 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29545 & IICH(210),IIBAR(210),K1(210),K2(210)
29548 * Particle masses Engel version JETSET compatible
29549 DATA (AAM(K),K=1,85) /
29550 & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
29551 & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
29552 & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
29553 & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
29554 & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
29555 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29556 & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
29557 & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
29558 & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
29559 & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
29560 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
29561 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
29562 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
29563 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
29564 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
29565 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
29566 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
29567 DATA (AAM(K),K=86,183) /
29568 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
29569 & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
29570 & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
29571 & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
29572 & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
29573 & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
29574 & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
29575 & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
29576 & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
29577 & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
29578 & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
29579 & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
29580 & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
29581 & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
29582 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
29583 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
29584 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
29585 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
29586 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
29587 & .1250D+01, .1250D+01, .1250D+01 /
29588 DATA (AAM ( I ), I = 184,210 ) /
29589 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
29590 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
29591 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
29592 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
29593 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
29594 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
29595 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
29596 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
29597 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
29598 * Particle mean lives
29599 DATA (TAU(K),K=1,183) /
29600 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
29601 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
29602 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
29603 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
29604 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
29606 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
29607 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
29608 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
29609 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
29610 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29611 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29612 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29613 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
29614 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29616 & .0000D+00, .0000D+00, .0000D+00 /
29617 DATA ( TAU ( I ), I = 184,210 ) /
29618 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29619 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29620 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29621 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29622 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29623 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29624 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29625 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29626 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
29627 * Resonance width Gamma in GeV
29628 DATA (GA(K),K= 1,85) /
29630 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
29631 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
29632 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
29633 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
29634 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
29635 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
29636 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
29637 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
29638 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
29639 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
29640 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
29641 DATA (GA(K),K= 86,183) /
29642 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
29643 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
29644 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29645 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
29646 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
29647 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
29648 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29649 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
29650 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
29652 & .3000D+00, .3000D+00, .3000D+00 /
29653 DATA ( GA ( I ), I = 184,210 ) /
29654 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
29655 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
29656 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
29657 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
29658 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
29659 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
29660 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
29661 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
29662 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
29664 * S+1385+Sigma+(1385) L02030+Lambda0(2030)
29665 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
29666 * designation N*@@ means N*@1(@2)
29667 DATA (ANAME(K),K=1,85) /
29668 & 'P ','AP ','E- ','E+ ','NUE ',
29669 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
29670 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
29671 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
29672 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
29673 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
29674 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
29675 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
29676 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
29677 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
29678 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
29679 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
29680 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
29681 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
29682 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
29683 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
29684 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
29685 DATA (ANAME(K),K=86,183) /
29686 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
29687 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
29688 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
29689 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
29690 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
29691 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
29692 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
29693 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
29694 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
29695 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
29696 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
29697 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
29698 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
29699 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
29700 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
29701 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
29702 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
29703 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
29704 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
29705 & 'RO ','R+ ','R- ' /
29706 DATA ( ANAME ( I ), I = 184,210 ) /
29707 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
29708 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
29709 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
29710 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
29711 &'N*+14 ','N*014 ','BLANK '/
29712 * Charge of particles and resonances
29713 DATA (IICH ( I ), I = 1,210 ) /
29714 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
29715 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29716 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
29717 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
29718 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
29719 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
29720 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
29721 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
29722 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
29723 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
29724 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
29725 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
29726 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
29727 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
29728 * Particle baryonic charges
29729 DATA (IIBAR ( I ), I = 1,210 ) /
29730 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
29731 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
29732 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29733 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29734 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
29735 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
29736 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
29737 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
29738 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29739 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
29740 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
29741 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
29742 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
29743 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
29744 * First number of decay channels used for resonances
29745 * and decaying particles
29746 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
29747 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
29748 & 2*330, 46, 51, 52, 54, 55, 58,
29750 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
29751 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
29752 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
29754 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
29755 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
29756 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
29757 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
29758 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
29759 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
29760 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
29761 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
29762 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
29763 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
29765 * Last number of decay channels used for resonances
29766 * and decaying particles
29767 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
29768 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
29769 & 2* 330, 50, 51, 53, 54, 57,
29771 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
29772 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
29773 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
29775 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
29776 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
29777 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
29778 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
29779 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
29780 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
29781 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
29782 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
29783 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
29784 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
29785 & 589, 595, 601, 602 /
29789 *===blkd47=============================================================*
29791 CDECK ID>, DT_BLKD47
29792 BLOCK DATA DT_BLKD47
29794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29797 * HADRIN: decay channel information
29798 PARAMETER (IDMAX9=602)
29800 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
29802 * Name of decay channel
29803 * Designation N*@ means N*@1(1236)
29804 * @1=# means ++, @1 = = means --
29805 * Designation P+/0/- means Pi+/Pi0/Pi- , respectively
29806 DATA (ZKNAME(K),K= 1, 85) /
29807 & 'P ','AP ','E- ','E+ ','NUE ',
29808 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
29809 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
29810 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
29811 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
29812 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
29813 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
29814 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
29815 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
29816 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
29817 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
29818 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
29819 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
29820 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
29821 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
29822 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
29823 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
29824 DATA (ZKNAME(K),K= 86,170) /
29825 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
29826 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
29827 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
29828 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
29829 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
29830 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
29831 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
29832 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
29833 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
29834 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
29835 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
29836 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
29837 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
29838 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
29839 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
29840 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
29841 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
29842 DATA (ZKNAME(K),K=171,255) /
29843 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
29844 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
29845 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
29846 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
29847 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
29848 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
29849 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
29850 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
29851 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
29852 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
29853 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
29854 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
29855 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
29856 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
29857 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
29858 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
29859 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
29860 DATA (ZKNAME(K),K=256,340) /
29861 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
29862 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
29863 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
29864 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
29865 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
29866 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
29867 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
29868 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
29869 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
29870 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
29871 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
29872 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
29873 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
29874 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
29875 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
29876 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
29877 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
29878 DATA (ZKNAME(K),K=341,425) /
29879 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
29880 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
29881 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
29882 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
29883 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
29884 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
29885 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
29886 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
29887 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
29888 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
29889 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
29890 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
29891 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
29892 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
29893 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
29894 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
29895 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
29896 DATA (ZKNAME(K),K=426,510) /
29897 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
29898 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
29899 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
29900 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
29901 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
29902 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
29903 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
29904 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
29905 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
29906 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
29907 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
29908 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
29909 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
29910 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
29911 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
29912 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
29913 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
29914 DATA (ZKNAME(K),K=511,540) /
29915 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
29916 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
29917 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
29918 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
29919 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
29920 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
29921 DATA (ZKNAME(I),I=541,602)/
29922 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
29923 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
29924 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
29925 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
29926 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
29927 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
29928 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
29929 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
29930 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
29931 * Weight of decay channel
29932 DATA (WT(K),K= 1, 85) /
29933 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
29934 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
29935 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
29936 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
29937 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
29938 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
29939 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
29940 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
29941 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
29942 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
29943 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
29944 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
29945 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
29946 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
29947 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
29948 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
29949 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
29950 DATA (WT(K),K= 86,170) /
29951 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
29952 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
29953 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
29954 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
29955 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
29956 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
29957 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
29958 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
29959 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
29960 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
29961 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
29962 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
29963 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
29964 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
29965 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
29966 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
29967 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
29968 DATA (WT(K),K=171,255) /
29969 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
29970 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
29971 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
29972 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
29973 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
29974 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
29975 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
29976 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
29977 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
29978 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
29979 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
29980 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
29981 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
29982 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
29983 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
29984 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
29985 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
29986 DATA (WT(K),K=256,340) /
29987 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
29988 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
29989 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
29990 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
29991 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
29992 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
29993 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
29994 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
29995 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
29996 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
29997 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
29998 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
29999 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30000 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30001 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30002 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
30003 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
30004 DATA (WT(K),K=341,425) /
30005 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
30006 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
30007 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
30008 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
30009 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
30010 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
30011 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
30012 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
30013 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
30014 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
30015 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
30016 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
30017 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
30018 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
30019 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
30020 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
30021 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
30022 DATA (WT(K),K=426,510) /
30023 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
30024 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
30025 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
30026 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
30027 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
30028 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
30029 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30030 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
30031 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
30032 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
30033 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
30034 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
30035 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
30036 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
30037 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
30038 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
30039 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
30040 DATA (WT(K),K=511,540) /
30041 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30042 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
30043 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30044 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30045 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
30046 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
30048 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
30049 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
30050 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
30051 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
30052 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
30053 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
30054 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
30055 * Particle numbers in decay channel
30056 DATA (NZK(K,1),K= 1,170) /
30057 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
30058 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
30059 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
30060 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
30061 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
30062 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
30063 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
30064 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
30065 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
30066 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
30067 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
30068 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
30069 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
30070 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
30071 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
30072 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
30073 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
30074 DATA (NZK(K,1),K=171,340) /
30075 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
30076 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
30077 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
30078 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
30079 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
30080 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
30081 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
30082 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
30083 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
30084 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
30085 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
30086 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
30087 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
30088 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
30089 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30090 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30091 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
30092 DATA (NZK(K,1),K=341,510) /
30093 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
30094 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
30095 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
30096 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
30097 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
30098 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
30099 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
30100 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
30101 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
30102 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
30103 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
30104 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
30105 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
30106 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
30107 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
30108 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
30109 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
30110 DATA (NZK(K,1),K=511,540) /
30111 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
30112 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
30113 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
30114 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
30115 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
30116 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
30117 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
30118 & 55, 8, 1, 8, 8, 54, 55, 210/
30119 DATA (NZK(K,2),K= 1,170) /
30120 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
30121 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
30122 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
30123 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
30124 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
30125 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
30126 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
30127 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
30128 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
30129 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
30130 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
30131 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
30132 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
30133 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
30134 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
30135 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
30136 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
30137 DATA (NZK(K,2),K=171,340) /
30138 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
30139 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
30140 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
30141 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
30142 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
30143 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
30144 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
30145 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
30146 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
30147 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
30148 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
30149 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
30150 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
30151 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
30152 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30153 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30154 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
30155 DATA (NZK(K,2),K=341,510) /
30156 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
30157 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
30158 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
30159 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
30160 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
30161 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
30162 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
30163 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
30164 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
30165 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
30166 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
30167 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
30168 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
30169 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
30170 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
30171 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
30172 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
30173 DATA (NZK(K,2),K=511,540) /
30174 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
30175 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
30176 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
30177 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
30178 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
30179 & 14, 14, 23, 14, 16, 25,
30180 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
30181 & 23, 13, 14, 23, 0 /
30182 DATA (NZK(K,3),K= 1,170) /
30183 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
30184 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
30185 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
30186 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
30187 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
30188 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
30190 DATA (NZK(K,3),K=171,340) /
30192 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
30193 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
30194 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
30195 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
30196 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
30198 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
30199 DATA (NZK(K,3),K=341,510) /
30201 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
30202 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
30203 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
30204 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30205 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
30206 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
30208 DATA (NZK(K,3),K=511,540) /
30209 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
30210 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30211 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
30212 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
30213 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
30218 *====phoini============================================================*
30220 CDECK ID>, DT_XHOINI
30221 SUBROUTINE DT_XHOINI
30222 C SUBROUTINE DT_PHOINI
30224 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30227 PARAMETER ( LINP = 5 ,
30234 *====eventb============================================================*
30236 CDECK ID>, DT_XVENTB
30237 SUBROUTINE DT_XVENTB(NCSY,IREJ)
30238 C SUBROUTINE DT_EVENTB(NCSY,IREJ)
30240 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30243 PARAMETER ( LINP = 5 ,
30248 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
30253 *===event==============================================================*
30255 CDECK ID>, DT_XVENT
30256 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
30257 C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
30259 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30262 DIMENSION PP(4),PT(4)
30267 *===pohisx=============================================================*
30269 CDECK ID>, DT_XOHISX
30270 SUBROUTINE DT_XOHISX(I,X)
30271 C SUBROUTINE POHISX(I,X)
30273 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30279 *===poluhi=============================================================*
30282 C SUBROUTINE XOLUHI(I,X)
30285 CDECK ID>, PHO_LHIST
30286 SUBROUTINE PHO_LHIST(I,X)
30290 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30297 C**********************************************************************
30299 C dummy subroutines, remove to link PDFLIB
30301 C**********************************************************************
30302 SUBROUTINE PDFSET(PARAM,VALUE)
30303 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30304 DIMENSION PARAM(20),VALUE(20)
30308 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
30309 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30312 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
30313 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30316 *===diqbrk=============================================================*
30318 CDECK ID>, DT_DIQBRK
30319 SUBROUTINE DT_XIQBRK
30320 C SUBROUTINE DT_DIQBRK
30322 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30325 STOP 'diquark-breaking not implemeted !'
30330 *===pho_rndm===========================================================*
30332 CDECK ID>, PHO_RNDM
30333 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
30335 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30338 PHO_RNDM = DT_RNDM(DUMMY)
30343 *===pyr================================================================*
30346 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
30348 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30351 DUMMY = DBLE(IDUMMY)
30352 PYR = DT_RNDM(DUMMY)
30357 *===elhain=============================================================*
30359 CDECK ID>, DT_ELHAIN
30360 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
30362 ************************************************************************
30363 * Elastic hadron-hadron scattering. *
30364 * This is a revised version of the original. *
30365 * This version dated 03.04.98 is written by S. Roesler *
30366 ************************************************************************
30368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30371 PARAMETER ( LINP = 5 ,
30375 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
30378 PARAMETER (ENNTHR = 3.5D0)
30379 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
30380 & BLOWB=0.05D0,BHIB=0.2D0,
30381 & BLOWM=0.1D0, BHIM=2.0D0)
30383 * particle properties (BAMJET index convention)
30385 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
30386 & IICH(210),IIBAR(210),K1(210),K2(210)
30387 * final state from HADRIN interaction
30388 PARAMETER (MAXFIN=10)
30389 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
30390 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
30392 C DATA TSLOPE /10.0D0/
30398 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
30399 EKIN = ELAB-AAM(IP)
30400 * kinematical quantities in cms of the hadrons
30403 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
30405 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
30406 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
30408 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
30409 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
30410 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
30411 * TSAMCS treats pp and np only, therefore change pn into np and
30417 IF (IP.EQ.8) KPROJ = 1
30419 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
30420 T = TWO*PCM**2*(CTCMS-ONE)
30422 * very crude treatment otherwise: sample t from exponential dist.
30424 * momentum transfer t
30425 TMAX = TWO*TWO*PCM**2
30426 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
30427 IF (IIBAR(IP).NE.0) THEN
30428 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
30430 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
30432 FMAX = EXP(-TSLOPE*TMAX)-ONE
30434 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
30435 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
30438 * target hadron in Lab after scattering
30439 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
30440 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
30441 IF (PLRH(2).LE.TINY10) THEN
30442 C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
30445 * projectile hadron in Lab after scattering
30446 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
30447 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
30448 * scattering angle of projectile in Lab
30449 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
30450 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
30451 CALL DT_DSFECF(SPLABP,CPLABP)
30452 * direction cosines of projectile in Lab
30453 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
30454 & CXRH(1),CYRH(1),CZRH(1))
30455 * scattering angle of target in Lab
30456 PLLABT = PLAB-CTLABP*PLRH(1)
30457 CTLABT = PLLABT/PLRH(2)
30458 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
30459 * direction cosines of target in Lab
30460 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
30461 & CXRH(2),CYRH(2),CZRH(2))
30470 *===tsamcs=============================================================*
30472 CDECK ID>, DT_TSAMCS
30473 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
30475 ************************************************************************
30476 * Sampling of cos(theta) for nucleon-proton scattering according to *
30477 * hetkfa2/bertini parametrization. *
30478 * This is a revised version of the original (HJM 24/10/88) *
30479 * This version dated 28.10.95 is written by S. Roesler *
30480 ************************************************************************
30482 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30485 PARAMETER ( LINP = 5 ,
30489 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
30492 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
30493 DIMENSION PDCI(60),PDCH(55)
30495 DATA (DCLIN(I),I=1,80) /
30496 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
30497 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
30498 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
30499 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
30500 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
30501 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
30502 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
30503 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
30504 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
30505 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
30506 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
30507 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
30508 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
30509 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
30510 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
30511 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
30512 DATA (DCLIN(I),I=81,160) /
30513 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
30514 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
30515 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
30516 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
30517 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
30518 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
30519 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
30520 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
30521 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
30522 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
30523 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
30524 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
30525 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
30526 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
30527 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
30528 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
30529 DATA (DCLIN(I),I=161,195) /
30530 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
30531 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
30532 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
30533 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
30534 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
30535 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
30536 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
30539 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
30540 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
30541 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
30542 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
30543 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
30544 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
30545 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
30546 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
30547 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
30548 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
30549 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
30550 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
30553 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
30554 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
30555 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
30556 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
30557 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
30558 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
30559 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
30560 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
30561 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
30562 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
30563 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
30565 DATA (DCHN(I),I=1,90) /
30566 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
30567 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
30568 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
30569 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
30570 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
30571 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
30572 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
30573 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
30574 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
30575 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
30576 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
30577 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
30578 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
30579 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
30580 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
30581 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
30582 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
30583 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
30584 DATA (DCHN(I),I=91,143) /
30585 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
30586 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
30587 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
30588 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
30589 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
30590 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
30591 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
30592 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
30593 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
30594 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
30595 & 6.488D-02, 6.485D-02, 6.480D-02/
30598 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
30599 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
30600 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
30601 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
30602 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
30603 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
30604 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
30608 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
30609 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
30610 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
30611 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
30612 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
30613 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
30614 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
30615 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
30616 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
30617 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
30618 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
30619 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
30622 IF (EKIN.GT.3.5D0) RETURN
30624 IF(KPROJ.EQ.8) GOTO 101
30625 IF(KPROJ.EQ.1) GOTO 102
30626 C* INVALID REACTION
30627 WRITE(LOUT,'(A,I5/A)')
30628 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
30629 & ' COS(THETA) = 1D0 RETURNED'
30631 C-------------------------------- NP ELASTIC SCATTERING----------
30633 IF (EKIN.GT.0.740D0)GOTO 1000
30634 IF (EKIN.LT.0.300D0)THEN
30635 C EKIN .LT. 300 MEV
30638 C 300 MEV < EKIN < 740 MEV
30643 IE=INT(ABS(ENER/0.020D0))
30644 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
30645 C FORWARD/BACKWARD DECISION
30647 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
30648 IF (DT_RNDM(CST).LT.BWFW)THEN
30656 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
30659 IF(RND.LT.COEF)THEN
30668 IF(VALUE2.GT.0.0)THEN
30669 CST=MAX(R1,R2,R3,R4)
30675 CST=-MAX(R1,R2,R3,R4,R5)
30679 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
30688 C******** EKIN .GT. 0.74 GEV
30690 1000 ENER=EKIN - 0.66D0
30691 C IE=ABS(ENER/0.02)
30692 IE=INT(ENER/0.02D0)
30695 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
30697 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
30700 IF (RND.GE.BWFW)THEN
30702 IF (DCHNA(K).GT.EMEV) THEN
30703 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
30704 UNIV=DT_RNDM(UNIVE)
30707 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
30710 UNIV=DT_RNDM(UNIVE)
30712 GOTO(290,290,290,290,330,340,350,360) I
30721 IF (DCHNB(K).GT.EMEV) THEN
30722 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
30723 UNIV=DT_RNDM(UNIVE)
30726 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
30731 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
30738 120 CST=1.0D-2*FLTI-1.0D0
30740 140 CST=2.0D-2*UNIV-0.98D0
30742 150 CST=4.0D-2*UNIV-0.96D0
30744 160 CST=6.0D-2*FLTI-1.16D0
30746 180 CST=8.0D-2*UNIV-0.80D0
30748 190 CST=1.0D-1*UNIV-0.72D0
30750 200 CST=1.2D-1*UNIV-0.62D0
30752 210 CST=2.0D-1*UNIV-0.50D0
30754 220 CST=3.0D-1*(UNIV-1.0D0)
30757 290 CST=1.0D0-2.5d-2*FLTI
30759 330 CST=0.85D0+0.5D-1*UNIV
30761 340 CST=0.70D0+1.5D-1*UNIV
30763 350 CST=0.50D0+2.0D-1*UNIV
30765 360 CST=0.50D0*UNIV
30769 C----------------------------------- PP ELASTIC SCATTERING -------
30774 IF (EKIN.LE.0.500D0) THEN
30776 CST=2.0D0*RND-1.0D0
30779 ELSEIF (EKIN.LT.1.0D0) THEN
30781 IF (PDCI(K).GT.EMEV) THEN
30782 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
30783 UNIV=DT_RNDM(UNIVE)
30787 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
30789 IF (UNIV.LT.SUM)THEN
30792 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
30799 IF (PDCH(K).GT.EMEV) THEN
30800 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
30801 UNIV=DT_RNDM(UNIVE)
30805 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
30807 IF (UNIV.LT.SUM)THEN
30810 GOTO(50,55,60,60,65,65,65,65,70,70) I
30821 60 CST=0.3D0+0.1D0*FLTI
30823 65 CST=0.6D0+0.04D0*FLTI
30825 70 CST=0.78D0+0.02D0*FLTI
30828 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
30833 *===dhadri=============================================================*
30835 CDECK ID>, DT_DHADRI
30836 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
30838 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30841 PARAMETER ( LINP = 5 ,
30846 C-----------------------------
30847 C*** INPUT VARIABLES LIST:
30848 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
30849 C*** GEV/C LABORATORY MOMENTUM REGION
30850 C*** N - PROJECTILE HADRON INDEX
30851 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
30852 C*** ELAB - LABORATORY ENERGY OF N (GEV)
30853 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
30854 C*** ITTA - TARGET NUCLEON INDEX
30855 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
30856 C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
30857 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
30858 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
30859 C*** RESPECT., UNITS (GEV/C AND GEV)
30860 C----------------------------
30862 COMMON /HNGAMR/ REDU,AMO,AMM(15)
30863 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
30864 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
30865 & NRK(2,268),NURE(30,2)
30866 * particle properties (BAMJET index convention),
30867 * (dublicate of DTPART for HADRIN)
30868 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
30869 & K1H(110),K2H(110)
30870 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
30871 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
30873 COMMON /HNDRUN/ RUNTES,EFTES
30874 * particle properties (BAMJET index convention)
30876 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
30877 & IICH(210),IIBAR(210),K1(210),K2(210)
30878 * final state from HADRIN interaction
30879 PARAMETER (MAXFIN=10)
30880 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
30881 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
30883 DIMENSION ITPRF(110)
30886 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
30888 IF (N.LE.0.OR.N.GE.111)N=1
30889 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
30892 * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
30894 *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
30895 * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
30898 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
30899 C IF(IPRI.GE.1) WRITE (6,1010) PLAB
30901 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
30902 + ALLOWED REGION, PLAB=',1E15.5)
30905 UMODAT=N*1.11111D0+ITTA*2.19291D0
30906 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
30913 IF (LOWP.GT.20) THEN
30914 C WRITE(LOUT,*) ' jump 1'
30918 IF (NNN.EQ.N) GO TO 50
30927 IF(ITTA.GT.1) IRE=NURE(N,2)
30929 C-----------------------------
30930 C*** IE,AMT,ECM,SI DETERMINATION
30931 C----------------------------
30932 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
30935 C IF (AMH(1).NE.0.93828D0) IANTH=1
30936 IF (AMH(1).NE.0.9383D0) IANTH=1
30938 IF (IANTH.GE.0) SI=1.0D0
30941 C-----------------------------
30943 C IRE CHARACTERIZES THE REACTION
30944 C IE IS THE ENERGY INDEX
30945 C----------------------------
30946 IF (SI.LT.1.D-6) THEN
30947 C WRITE(LOUT,*) ' jump 2'
30950 IF (N.LE.NSTAB) GO TO 60
30951 RUNTES=RUNTES+1.0D0
30952 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
30953 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
30954 IF(IBARH(N).EQ.1) N=8
30955 IF(IBARH(N).EQ.-1) N=9
30958 **sr 19.2.97: loop for direct channel suppression
30959 C IF (IMACH.GT.10) THEN
30960 IF (IMACH.GT.1000) THEN
30962 C WRITE(LOUT,*) ' jump 3'
30968 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
30969 IF(ECMN.LE.AMN) ECMN=AMN
30970 PCMN=SQRT(ECMN**2-AMN2)
30973 IF (IANTH.GE.0) ECM=2.1D0
30975 C-----------------------------
30976 C*** RANDOM CHOICE OF REACTION CHANNEL
30977 C----------------------------
30982 C-----------------------------
30983 C*** PLACE REDUCED VERSION
30984 C----------------------------
30986 IDWK=IEII(IRE+1)-IIEI
30990 C-----------------------------
30991 C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
30992 C----------------------------
30994 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
30995 IF (HUMO.LT.ECM) ECM=HUMO
30997 C-----------------------------
30998 C*** INTERPOLATION PREPARATION
30999 C----------------------------
31005 C-----------------------------
31007 C----------------------------
31012 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
31016 C-----------------------------
31017 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
31018 C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
31020 C----------------------------
31021 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
31022 WICO=WOK*1.23459876D0+WDK*1.735218469D0
31023 IF (WICO.EQ.WICOR) GO TO 70
31024 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
31027 C-----------------------------
31028 C*** INTERPOLATION IN CHANNEL WEIGHTS
31029 C----------------------------
31030 EKLIM=-THRESH(IIKI+IK)
31031 IELIM=IDT_IEFUND(EKLIM,IRE)
31032 DELIM=UMO(IELIM)+EKLIM
31034 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
31035 IF (DELIM*DELIM-DETE*DETE) 90,90,80
31040 WKK=WOK-WDK*DEC/(DECC+1.D-9)
31042 C-----------------------------
31044 C----------------------------
31046 IF (VV.GT.WKK) GO TO 70
31048 C***IK IS THE REACTION CHANNEL
31049 C----------------------------
31061 IF (I1001.GT.50) GO TO 60
31063 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
31066 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
31069 IF (IT2.GT.0) GO TO 120
31070 **sr 19.2.97: supress direct channel for pp-collisions
31071 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
31073 IF (RR.LE.0.75D0) GOTO 60
31077 C-----------------------------
31078 C INCLUSION OF DIRECT RESONANCES
31079 C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
31080 C------------------------
31093 IF(WW.LT. 0.5D0) GO TO 130
31100 C-----------------------------
31101 C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
31108 IF(IB1.EQ.IBN) GO TO 140
31114 C-----------------------------
31115 C***IT1,IT2 ARE THE CREATED PARTICLES
31116 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
31117 C------------------------
31118 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
31119 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
31124 C-----------------------------
31125 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
31126 C----------------------------
31127 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
31128 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31132 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
31133 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31136 C-----------------------------
31137 C***TEST STABLE OR UNSTABLE
31138 C----------------------------
31139 IF(ITS(IST).GT.NSTAB) GO TO 160
31142 C-----------------------------
31143 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
31144 C----------------------------
31145 C* IF (REDU.LT.0.D0) GO TO 1009
31153 IF(IST.GE.1) GO TO 150
31157 C RANDOM CHOICE OF DECAY CHANNELS
31158 C----------------------------
31172 IF (VV.GT.WTI(IIK)) GO TO 180
31174 C IIK IS THE DECAY CHANNEL
31175 C----------------------------
31183 IF (IT2-1.LT.0) GO TO 240
31188 C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
31189 C----------------------------
31190 IF (IECO.LE.10) GO TO 200
31192 IF(IATMPT.GT.3) THEN
31193 C WRITE(LOUT,*) ' jump 4'
31198 IF (I310.GT.50) GO TO 170
31199 IF (AMS.GT.ECO) GO TO 190
31201 C FOR THE DECAY CHANNEL
31202 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
31203 C----------------------------
31204 IF (REDU.LT.0.D0) GO TO 30
31207 IF(IT3.EQ.0) GO TO 220
31210 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
31211 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
31213 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
31214 &COD2,COF2,SIF2,AM1,AM2)
31219 IF (REDU.GT.0.D0) GO TO 240
31221 IF (ITWTHC.GT.100) GO TO 30
31222 IF (ITWTH) 220,220,210
31225 IF (IT2-1.LT.0) GO TO 250
31232 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
31233 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31236 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
31237 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31238 IF (IT3.LE.0) GO TO 250
31241 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
31242 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31250 C----------------------------
31252 C ZERO CROSS SECTION CASE
31253 C----------------------------
31265 *===runtt==============================================================*
31267 CDECK ID>, DT_RUNTT
31268 BLOCK DATA DT_RUNTT
31270 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31273 COMMON /HNDRUN/ RUNTES,EFTES
31275 DATA RUNTES,EFTES /100.D0,100.D0/
31279 *===noname=============================================================*
31281 CDECK ID>, DT_NONAME
31282 BLOCK DATA DT_NONAME
31284 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31287 * slope parameters for HADRIN interactions
31288 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
31289 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31291 C DATAS DATAS DATAS DATAS DATAS
31293 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
31294 & 207, 224, 241, 252, 268 /
31295 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
31296 & 220, 241, 262, 279, 296 /
31297 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
31298 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
31301 C MASSES FOR THE SLOPE B(M) IN GEV
31302 C SLOPE B(M) FOR AN MESONIC SYSTEM
31303 C SLOPE B(M) FOR A BARYONIC SYSTEM
31306 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
31307 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
31308 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
31309 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
31310 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
31311 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
31312 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
31313 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
31314 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
31315 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
31316 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
31317 & 14.2D0, 13.4D0, 12.6D0,
31318 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
31319 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
31323 *===damg===============================================================*
31326 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
31328 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31331 * particle properties (BAMJET index convention),
31332 * (dublicate of DTPART for HADRIN)
31333 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31334 & K1H(110),K2H(110)
31336 DIMENSION GASUNI(14)
31338 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
31339 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
31340 DATA GAUNO/2.352D0/
31346 IF (IT.LE.0) GO TO 30
31347 IF (IT.LE.NSTAB) GO TO 20
31348 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
31350 VV=VV*2.0D0-1.0D0+1.D-16
31355 IF (VV.GT.V1) GO TO 10
31356 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
31357 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
31358 DAM=GAH(IT)*UNIGA/GAUNO
31370 *===dcalum=============================================================*
31372 CDECK ID>, DT_DCALUM
31373 SUBROUTINE DT_DCALUM(N,ITTA)
31375 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31378 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
31380 * particle properties (BAMJET index convention),
31381 * (dublicate of DTPART for HADRIN)
31382 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31383 & K1H(110),K2H(110)
31384 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31385 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
31386 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31387 & NRK(2,268),NURE(30,2)
31389 IRE=NURE(N,ITTA/8+1)
31398 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
31405 IF(NRK(2,IK).GT.0) GO TO 30
31414 IF(IN.GT.0)AMS=AMS+AMH(IN)
31416 IF(IN.GT.0) AMS=AMS+AMH(IN)
31417 IF (AMS.LT.AMSS) AMSS=AMS
31419 IF(UMOO.LT.AMSS) UMOO=AMSS
31425 *===dchanh=============================================================*
31427 CDECK ID>, DT_DCHANH
31428 SUBROUTINE DT_DCHANH
31430 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31433 PARAMETER ( LINP = 5 ,
31437 * particle properties (BAMJET index convention),
31438 * (dublicate of DTPART for HADRIN)
31439 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31440 & K1H(110),K2H(110)
31441 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
31442 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31443 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31444 & NRK(2,268),NURE(30,2)
31446 DIMENSION HWT(460),HWK(40),SI(5184)
31447 EQUIVALENCE (WK(1),SI(1))
31448 C--------------------
31449 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
31450 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
31451 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
31452 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
31453 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
31454 C--------------------------
31458 IEE=IEII(IRE+1)-IEII(IRE)
31459 IKE=IKII(IRE+1)-IKII(IRE)
31462 * modifications to suppress elestic scattering 24/07/91
31467 IWK=IWKO+IEE*(IK-1)+IE
31468 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
31469 SIS=SIS+SI(IWK)*SINORC
31473 IF (SIS.GE.1.D-12) GO TO 20
31479 IWK=IWKO+IEE*(IK-1)+IE
31480 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
31481 SIO=SIO+SI(IWK)*SINORC/SIS
31485 IWK=IWKO+IEE*(IK-1)+IE
31490 INRK1=NRK(1,IIKI+IK)
31491 IF (INRK1.GT.0) AM111=AMH(INRK1)
31493 INRK2=NRK(2,IIKI+IK)
31494 IF (INRK2.GT.0) AM222=AMH(INRK2)
31495 THRESH(IIKI+IK)=AM111 +AM222
31496 IF (INRK2-1.GE.0) GO TO 60
31500 DO 50 INRK1=INRKK,INRKO
31501 INZK1=NZKI(INRK1,1)
31502 INZK2=NZKI(INRK1,2)
31503 INZK3=NZKI(INRK1,3)
31504 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
31505 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
31506 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
31507 C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
31509 AMS=AMH(INZK1)+AMH(INZK2)
31510 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
31511 IF (AMSS.GT.AMS) AMSS=AMS
31514 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
31515 THRESH(IIKI+IK)=AMS
31526 IF (IK2.GT.460)IK2=460
31533 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
31534 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
31541 *===dhadde=============================================================*
31543 CDECK ID>, DT_DHADDE
31544 SUBROUTINE DT_DHADDE
31546 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31549 * particle properties (BAMJET index convention)
31551 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31552 & IICH(210),IIBAR(210),K1(210),K2(210)
31553 * HADRIN: decay channel information
31554 PARAMETER (IDMAX9=602)
31556 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31557 * particle properties (BAMJET index convention),
31558 * (dublicate of DTPART for HADRIN)
31559 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31560 & K1H(110),K2H(110)
31561 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
31562 * decay channel information for HADRIN
31563 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
31564 & K1Z(16),K2Z(16),WTZ(153),II22,
31565 & NZK1(153),NZK2(153),NZK3(153)
31571 IF (IRETUR.GT.1) RETURN
31577 IBARH(I) = IIBAR(I)
31592 NZKI(I,1) = NZK(I,1)
31593 NZKI(I,2) = NZK(I,2)
31594 NZKI(I,3) = NZK(I,3)
31609 NZKI(L,3) = NZK3(I)
31610 NZKI(L,2) = NZK2(I)
31611 NZKI(L,1) = NZK1(I)
31616 *===iefund=============================================================*
31618 CDECK ID>, IDT_IEFUND
31619 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
31621 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31624 C*****IEFUN CALCULATES A MOMENTUM INDEX
31626 PARAMETER ( LINP = 5 ,
31630 COMMON /HNDRUN/ RUNTES,EFTES
31631 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31632 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31633 & NRK(2,268),NURE(30,2)
31638 IF (PL.LT.0.) GO TO 30
31641 IF (PL.LE.PLABF(I)) GO TO 60
31644 IF ( EFTES.GT.40.D0) GO TO 20
31646 WRITE(LOUT,1000)PL,J
31652 IF (-PL.LE.UMO(I)) GO TO 60
31655 IF ( EFTES.GT.40.D0) GO TO 50
31657 WRITE(LOUT,1000)PL,I
31663 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
31667 *===dsigin=============================================================*
31669 CDECK ID>, DT_DSIGIN
31670 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
31672 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31675 * particle properties (BAMJET index convention),
31676 * (dublicate of DTPART for HADRIN)
31677 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31678 & K1H(110),K2H(110)
31679 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31680 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31681 & NRK(2,268),NURE(30,2)
31683 IE=IDT_IEFUND(PLAB,IRE)
31684 IF (IE.LE.IEII(IRE)) IE=IE+1
31689 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
31690 C*** INTERPOLATION PREPARATION
31696 EKLIM=-THRESH(IIKI)
31699 IF (ECM.GT.ECMO) WDK=0.0D0
31700 C*** INTERPOLATION IN CHANNEL WEIGHTS
31701 IELIM=IDT_IEFUND(EKLIM,IRE)
31702 DELIM=UMO(IELIM)+EKLIM
31704 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
31705 IF (DELIM*DELIM-DETE*DETE) 20,20,10
31710 WKK=WOK-WDK*DEC/(DECC+1.D-9)
31711 IF (WKK.LT.0.0D0) WKK=0.0D0
31713 IF (-EKLIM.GT.ECM) SI=1.D-14
31717 *===dtchoi=============================================================*
31719 CDECK ID>, DT_DTCHOI
31720 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
31722 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31725 C ****************************
31726 C TCHOIC CALCULATES A RANDOM VALUE
31727 C FOR THE FOUR-MOMENTUM-TRANSFER T
31728 C ****************************
31730 * particle properties (BAMJET index convention),
31731 * (dublicate of DTPART for HADRIN)
31732 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31733 & K1H(110),K2H(110)
31734 * slope parameters for HADRIN interactions
31735 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
31739 IF (I.GT.30.AND.II.GT.30) GO TO 20
31742 IF (I.LE.30) GO TO 10
31750 IF (AMA.LE.AMB) GO TO 30
31756 K=INT((AMA-0.75D0)/0.05D0)
31758 IF (K-26.GE.0) K=25
31765 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
31766 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
31769 C IF (VB.LT.0.2D0) BM=BM*0.1
31776 IF (ABS(TMA).GT.120.D0) GO TO 70
31779 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
31780 C*** RANDOM CHOICE OF THE T - VALUE
31782 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
31786 *===dtwopa=============================================================*
31788 CDECK ID>, DT_DTWOPA
31789 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
31790 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
31792 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31795 C ******************************************************
31796 C QUASI TWO PARTICLE PRODUCTION
31797 C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
31798 C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
31799 C IN THE CM - SYSTEM
31800 C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
31801 C SPHERICAL COORDINATES
31802 C ******************************************************
31804 * particle properties (BAMJET index convention),
31805 * (dublicate of DTPART for HADRIN)
31806 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31807 & K1H(110),K2H(110)
31812 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
31814 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
31815 AMTE=(E1-AMA)*(E1+AMA)
31819 C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
31820 C DETERMINATION OF THE ANGLES
31821 C COS(THETA1)=COD1 COS(THETA2)=COD2
31822 C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
31823 C COS(PHI1)=COF1 COS(PHI2)=COF2
31824 C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
31825 CALL DT_DSFECF(COF1,SIF1)
31828 C CALCULATION OF THETA1
31829 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
31830 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
31831 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
31836 *===zk=================================================================*
31841 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31844 * decay channel information for HADRIN
31845 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
31846 & K1Z(16),K2Z(16),WTZ(153),II22,
31847 & NZK1(153),NZK2(153),NZK3(153)
31848 * decay channel information for HADRIN
31849 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
31850 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
31852 * Particle masses in GeV *
31853 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
31855 * Resonance width Gamma in GeV *
31856 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
31857 * Mean life time in seconds *
31858 DATA TAUZ / 16*0.D0 /
31859 * Charge of particles and resonances *
31860 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
31861 * Baryonic charge *
31862 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
31863 * First number of decay channels used for resonances *
31864 * and decaying particles *
31865 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
31867 * Last number of decay channels used for resonances *
31868 * and decaying particles *
31869 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
31871 * Weight of decay channel *
31872 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
31873 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
31874 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
31875 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
31876 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
31877 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
31878 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
31879 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
31880 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
31881 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
31882 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
31883 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
31884 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
31885 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
31886 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
31887 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
31888 & .05D0, .65D0, 9*1.D0 /
31889 * Particle numbers in decay channel *
31890 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
31891 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
31892 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
31893 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
31894 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
31895 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
31896 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
31897 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
31898 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
31899 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
31900 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
31901 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
31902 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
31903 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
31904 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
31905 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
31906 & 1, 8, 1, 8, 1, 9*0 /
31907 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
31908 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
31909 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
31910 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
31911 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
31912 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
31914 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
31915 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
31917 * Name of decay channel *
31918 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
31919 & 'ANNPI0','APPPI0','ANPPI-'/
31920 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
31921 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
31922 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
31923 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
31924 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
31925 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
31926 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
31928 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
31929 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
31930 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
31931 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
31932 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
31933 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
31934 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
31935 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
31936 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
31937 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
31938 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
31939 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
31940 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
31945 *===blkd43=============================================================*
31947 CDECK ID>, DT_BLKD43
31948 BLOCK DATA DT_BLKD43
31950 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31956 *=== reac =============================================================*
31958 *----------------------------------------------------------------------*
31960 * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
31963 * Last change on 10-dec-91 by Alfredo Ferrari *
31965 * This is the original common reac of Hadrin *
31967 *----------------------------------------------------------------------*
31969 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31970 & NRK(2,268),NURE(30,2)
31973 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
31974 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
31975 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
31976 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
31977 & SPIKP5(187), SPIKP6(289),
31978 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
31979 & SPIKP9(143), SPIKP0(169), SPKPV(143),
31980 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
31981 & SANPEL(84) , SPIKPF(273),
31982 & SPKP15(187), SPKP16(272),
31983 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
31986 DIMENSION NRKLIN(532)
31987 EQUIVALENCE (NRK(1,1), NRKLIN(1))
31988 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
31989 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
31990 EQUIVALENCE ( UMO(263), UMOK0(1))
31991 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
31992 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
31993 EQUIVALENCE ( PLABF(263), PLAK0(1))
31994 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
31995 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
31996 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
31997 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
31998 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
31999 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
32000 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
32001 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
32002 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
32003 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
32004 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
32005 EQUIVALENCE ( WK(4913), SPKP16(1))
32006 EQUIVALENCE (NRK(1,1), NRKLIN(1))
32007 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
32008 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
32009 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
32010 EQUIVALENCE (NURE(1,1), NURELN(1))
32014 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
32015 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
32016 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
32017 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
32018 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
32019 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
32020 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
32021 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
32022 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
32023 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
32025 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32026 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32027 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32028 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32029 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32030 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32031 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32032 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32033 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32034 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32035 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32036 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
32038 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32039 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32040 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32041 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32042 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32043 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
32046 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32047 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
32048 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32049 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
32050 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32051 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
32052 * app apn anp ann *
32054 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
32055 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32056 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
32057 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
32058 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32059 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
32060 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
32061 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32062 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
32063 DATA SIIN / 296*0.D0 /
32064 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
32065 & 1.557D0,1.615D0,1.6435D0,
32066 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
32067 & 2.286D0,2.366D0,2.482D0,2.56D0,
32069 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
32070 & 1.496D0,1.527D0,1.557D0,
32071 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
32072 & 2.071D0,2.159D0,2.286D0,2.366D0,
32073 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
32074 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
32075 & 1.496D0,1.527D0,1.557D0,
32076 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
32077 & 2.071D0,2.159D0,2.286D0,2.366D0,
32078 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
32079 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
32080 & 1.557D0,1.615D0,1.6435D0,
32081 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
32082 & 2.286D0,2.366D0,2.482D0,2.56D0,
32084 DATA UMOKC/ 1.44D0,
32085 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32086 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32088 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32089 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32091 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32092 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32094 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32095 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32097 DATA UMOK0/ 1.44D0,
32098 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32099 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32101 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32102 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32106 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32107 & 3.D0,3.1D0,3.2D0,
32108 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32109 & 3.D0,3.1D0,3.2D0,
32110 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32111 & 3.D0,3.1D0,3.2D0/
32112 * app apn anp ann *
32114 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
32115 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32116 & 3.D0,3.1D0,3.2D0,
32117 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
32118 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32119 & 3.D0,3.1D0,3.2D0,
32120 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
32121 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32122 & 3.D0,3.1D0,3.2D0/
32123 **** reaction channel state particles *
32124 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
32125 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
32126 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
32127 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
32128 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
32129 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
32130 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
32131 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
32132 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
32133 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
32134 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
32135 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
32136 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
32137 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
32138 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
32139 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
32140 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
32141 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
32143 * k0 p k0 n ak0 p ak/ n *
32145 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
32146 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
32147 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
32148 & 53, 47, 1, 103, 0, 93, 0/
32150 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
32151 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
32152 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
32153 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
32154 * app apn anp ann *
32155 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
32156 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
32157 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
32158 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
32159 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
32160 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
32161 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
32162 **** channel cross section *
32163 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
32164 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
32165 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
32166 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
32167 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
32168 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
32169 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
32170 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
32171 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
32172 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
32173 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
32174 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
32175 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
32176 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
32177 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
32178 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
32179 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
32180 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
32181 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
32182 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
32184 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
32185 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
32186 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
32187 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
32188 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
32189 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
32190 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
32191 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
32192 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
32193 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
32194 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
32195 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
32196 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
32197 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
32198 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
32199 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
32200 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
32201 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
32202 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
32203 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
32205 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
32206 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
32207 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
32208 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
32209 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
32210 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
32211 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
32212 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
32213 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
32214 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
32215 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
32216 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
32217 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
32218 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
32219 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
32220 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
32221 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
32222 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
32223 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
32224 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
32226 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
32227 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
32228 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
32229 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
32230 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
32231 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
32232 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
32233 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
32234 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
32235 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
32236 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
32237 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
32238 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
32239 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
32240 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
32241 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
32242 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
32243 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
32244 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
32246 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
32247 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
32248 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
32249 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
32250 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
32251 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
32252 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
32253 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
32254 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
32255 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
32256 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
32257 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
32258 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
32259 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
32260 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
32261 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
32262 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
32263 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
32264 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
32265 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
32267 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
32268 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
32269 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
32270 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
32271 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
32272 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
32273 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
32274 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
32275 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
32276 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
32277 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
32278 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
32279 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
32280 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
32281 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
32282 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
32283 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
32284 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
32285 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
32286 & 3.3D0, 5.4D0, 7.D0 /
32288 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
32289 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
32290 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
32291 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
32292 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
32293 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
32294 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
32295 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
32296 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
32297 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
32298 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
32299 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
32300 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
32302 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
32303 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
32304 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
32305 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
32306 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
32307 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
32308 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
32309 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
32310 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
32311 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
32312 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
32313 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
32314 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
32315 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
32316 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
32317 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
32318 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
32319 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
32320 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
32322 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
32323 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
32324 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
32325 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
32326 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
32327 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
32328 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
32329 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
32330 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
32331 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
32332 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
32333 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
32334 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
32335 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
32336 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
32337 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
32338 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
32339 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
32340 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
32341 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
32342 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
32343 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
32344 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
32345 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
32346 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
32347 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
32348 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
32349 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
32350 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
32351 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
32352 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
32353 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
32356 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
32357 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
32358 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
32359 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
32360 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
32361 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
32362 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
32363 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
32364 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
32365 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
32366 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
32367 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
32368 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
32369 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
32370 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
32371 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
32372 & .39D0, .22D0, .07D0, 0.D0,
32373 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
32374 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
32375 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
32376 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
32377 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
32378 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
32379 & 5.10D0, 5.44D0, 5.3D0,
32380 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
32382 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
32383 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
32384 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
32385 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
32386 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
32387 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
32388 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
32389 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
32390 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
32391 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
32392 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
32393 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
32394 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
32395 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
32396 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
32398 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
32399 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
32400 & 0.D0, 1.8D0, .2D0, 12*0.D0,
32401 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
32402 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
32403 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
32404 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
32405 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
32406 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
32407 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
32408 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
32409 & 10*0.D0, .7D0, 5.1D0, 8.D0,
32410 & 10*0.D0, .7D0, 5.1D0, 8.D0,
32411 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
32412 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
32413 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
32414 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
32415 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
32418 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
32419 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
32420 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
32421 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
32422 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
32423 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
32424 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
32425 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
32426 & 11.D0, 5.5D0, 3.5D0,
32427 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
32428 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
32429 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
32430 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
32431 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
32432 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
32433 **************** ap - p - data *
32434 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
32435 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
32436 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
32437 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
32438 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
32439 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
32440 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
32441 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
32442 & 1.55D0, 1.3D0, .95D0, .75D0,
32443 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
32444 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
32445 & .01D0, .008D0, .006D0, .005D0/
32446 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
32447 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
32448 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
32449 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
32450 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
32451 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
32452 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
32453 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
32454 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
32455 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
32456 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
32457 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
32458 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
32459 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
32460 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
32461 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
32462 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
32463 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
32464 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
32465 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
32466 **************** ap - n - data *
32468 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
32469 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
32470 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
32471 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
32472 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
32473 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
32474 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
32475 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
32476 & .01D0, .008D0, .006D0, .005D0 /
32477 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
32478 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
32479 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
32480 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32481 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
32482 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
32483 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
32484 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32485 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32486 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32487 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
32488 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
32489 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
32490 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
32493 **************** an - p - data *
32496 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
32497 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
32498 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
32499 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
32500 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
32501 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
32502 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
32503 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
32504 & .01D0, .008D0, .006D0, .005D0 /
32505 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
32506 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
32507 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
32508 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32509 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
32510 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
32511 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
32512 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32513 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32514 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32515 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
32516 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
32517 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
32518 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
32519 **** ko - n - data *
32520 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
32521 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
32522 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
32523 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
32524 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
32525 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
32526 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
32527 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
32528 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
32529 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
32530 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
32532 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
32533 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
32534 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
32535 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
32536 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
32537 **** ako - p - data *
32538 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
32539 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
32540 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
32541 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
32542 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
32543 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
32544 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
32545 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
32546 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
32547 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
32548 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
32549 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
32550 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
32551 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
32552 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
32553 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
32554 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
32555 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
32556 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
32557 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
32558 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
32559 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
32560 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
32561 *= end*block.blkdt3 *
32564 *===qel_pol============================================================*
32566 CDECK ID>, DT_QEL_POL
32567 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
32569 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32573 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
32578 C==================================================================
32579 C Generation of a Quasi-Elastic neutrino scattering
32580 C==================================================================
32582 *===gen_qel============================================================*
32584 CDECK ID>, DT_GEN_QEL
32585 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
32587 C...Generate a quasi-elastic neutrino/antineutrino
32588 C. Interaction on a nuclear target
32589 C. INPUT : LTYP = neutrino type (1,...,6)
32590 C. ENU (GeV) = neutrino energy
32591 C----------------------------------------------------
32593 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32596 PARAMETER ( LINP = 5 ,
32600 PARAMETER (MAXLND=4000)
32601 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
32603 * nuclear potential
32605 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
32606 & EBINDP(2),EBINDN(2),EPOT(2,210),
32607 & ETACOU(2),ICOUL,LFERMI
32608 * steering flags for qel neutrino scattering modules
32609 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
32610 **sr - removed (not needed)
32611 C COMMON /CBAD/ LBAD, NBAD
32612 C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
32615 DIMENSION PI(3),PO(3)
32620 C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
32621 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
32622 DATA AMN /0.93827231D0, 0.93956563D0/
32623 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
32626 C DATA PFERMI/0.22D0/
32627 CGB+...Binding Energy
32628 DATA EBIND/0.008D0/
32632 IF(ININU.EQ.1)NDSIG=0
32637 AML = AML0(LTYP) ! massa leptoni
32638 AML2 = AML**2 ! massa leptoni **2
32639 C...Particle labels (LUND)
32649 K0 = (LTYP-1)/2 ! 2
32651 KA = 12 + 2*K0 ! 16
32652 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
32656 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
32657 IF (LNU .EQ. 2) THEN
32685 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
32686 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
32691 C...4-momentum initial lepton
32692 P(1,5) = 0. ! massa
32693 P(1,4) = ENU0 ! energia
32698 C PF = PFERMI*PYR(0)**(1./3.)
32699 c write(23,*) PYR(0)
32700 c write(*,*) 'Pfermi=',PF
32703 C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
32704 IF (NTRY .GT. 500) THEN
32706 WRITE (LOUT,1001) NBAD, ENU
32709 C CT = -1. + 2.*PYR(0)
32711 C ST = SQRT(1.-CT*CT)
32712 C F = 2.*3.1415926*PYR(0)
32715 C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
32716 C P(2,1) = PF*ST*COS(F) ! px
32717 C P(2,2) = PF*ST*SIN(F) ! py
32718 C P(2,3) = PF*CT ! pz
32719 C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
32725 beta1=-p(2,1)/p(2,4)
32726 beta2=-p(2,2)/p(2,4)
32727 beta3=-p(2,3)/p(2,4)
32729 C WRITE(6,*)' before transforming into target rest frame'
32731 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
32733 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
32736 phi11=atan(p(1,2)/p(1,3))
32741 CALL DT_TESTROT(PI,Po,PHI11,1)
32743 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32749 phi12=atan(p(1,1)/p(1,3))
32754 CALL DT_TESTROT(Pi,Po,PHI12,2)
32756 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32765 C...Kinematical limits in Q**2
32766 c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
32767 S = P(2,5)**2 + 2.*ENU*P(2,5)
32768 SQS = SQRT(S) ! E centro massa
32769 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
32770 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
32771 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
32772 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
32773 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
32774 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
32775 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
32778 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
32779 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
32780 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
32781 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
32782 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
32784 C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
32785 C &Q2,Q2min,Q2MAX,DSIGEV
32787 C...c.m. frame. Neutrino along z axis
32788 DETOT = (P(1,4)) + (P(2,4)) ! e totale
32789 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
32790 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
32791 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
32794 C WRITE(*,*) 'Input values laboratory frame'
32797 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
32800 c STHETA = ULANGL(P(1,3),P(1,1))
32801 c write(*,*) 'stheta' ,stheta
32803 c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
32806 C WRITE(*,*) 'Output values cm frame'
32807 C...Kinematic in c.m. frame
32808 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
32809 STSTAR = SQRT(1.-CTSTAR**2)
32810 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
32811 P(4,5) = AML ! massa leptone
32812 P(4,4) = ELF ! e leptone
32813 P(4,3) = PLF*CTSTAR ! px
32814 P(4,1) = PLF*STSTAR*COS(PHI) ! py
32815 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
32817 P(5,5) = AMF ! barione
32818 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
32819 P(5,3) = -P(4,3) ! px
32820 P(5,1) = -P(4,1) ! py
32821 P(5,2) = -P(4,2) ! pz
32824 P(3,1) = P(1,1)-P(4,1)
32825 P(3,2) = P(1,2)-P(4,2)
32826 P(3,3) = P(1,3)-P(4,3)
32827 P(3,4) = P(1,4)-P(4,4)
32829 C...Transform back to laboratory frame
32830 C WRITE(*,*) 'before going back to nucl rest frame'
32831 c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
32834 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
32836 C WRITE(*,*) 'Now back in nucl rest frame'
32837 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
32839 c********************************************
32845 CALL DT_TESTROT(Pi,Po,PHI12,3)
32847 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32853 c********************************************
32859 CALL DT_TESTROT(Pi,Po,PHI11,4)
32861 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32868 c********************************************
32870 C WRITE(*,*) 'Now back in lab frame'
32872 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
32875 C...test (on final momentum of nucleon) if Fermi-blocking
32877 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
32879 IF (ENUCL.LT. EFMAX) THEN
32880 IF(INIPRI.LT.10)THEN
32882 C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
32883 C...the interaction is not possible due to Pauli-Blocking and
32884 C...it must be resampled
32887 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
32888 IF(INIPRI.LT.10)THEN
32890 C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
32892 C Reject (J:R) here all these events
32893 C are otherwise rejected in dpmjet
32895 C...the interaction is possible, but the nucleon remains inside
32896 C...the nucleus. The nucleus is therefore left excited.
32897 C...We treat this case as a nucleon with 0 kinetic energy.
32903 ELSE IF (ENUCL.GE.ENWELL) THEN
32904 C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
32905 C...the interaction is possible, the nucleon can exit the nucleus
32906 C...but the nuclear well depth must be subtracted. The nucleus could be
32907 C...left in an excited state.
32908 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
32909 C P(5,4) = ENUCL-ENWELL + AMF
32910 Pnucl = SQRT(P(5,4)**2-AMF**2)
32911 C...The 3-momentum is scaled assuming that the direction remains
32913 P(5,1) = P(5,1) * Pnucl/Pstart
32914 P(5,2) = P(5,2) * Pnucl/Pstart
32915 P(5,3) = P(5,3) * Pnucl/Pstart
32916 C WRITE(6,*)' qel new P(5,4) ',P(5,4)
32919 DSIGSU=DSIGSU+DSIGEV
32929 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
32931 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
32935 C PRINT*,' FINE EVENTO '
32939 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
32942 C====================================================================
32944 C====================================================================
32947 *===mass_ini===========================================================*
32949 CDECK ID>, DT_MASS_INI
32950 SUBROUTINE DT_MASS_INI
32951 C...Initialize the kinematics for the quasi-elastic cross section
32953 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32956 * particle masses used in qel neutrino scattering modules
32957 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
32958 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
32959 & EMPROTSQ,EMNEUTSQ,EMNSQ
32961 EML(1) = 0.51100D-03 ! e-
32962 EML(2) = EML(1) ! e+
32963 EML(3) = 0.105659D0 ! mu-
32964 EML(4) = EML(3) ! mu+
32965 EML(5) = 1.7777D0 ! tau-
32966 EML(6) = EML(5) ! tau+
32967 EMPROT = 0.93827231D0 ! p
32968 EMNEUT = 0.93956563D0 ! n
32969 EMPROTSQ = EMPROT**2
32970 EMNEUTSQ = EMNEUT**2
32971 EMN = (EMPROT + EMNEUT)/2.
32975 EMN1(J0+1) = EMNEUT
32976 EMN1(J0+2) = EMPROT
32977 EMN2(J0+1) = EMPROT
32978 EMN2(J0+2) = EMNEUT
32981 EMLSQ(J) = EML(J)**2
32982 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
32987 *===dsqel_q2===========================================================*
32989 CDECK ID>, DT_DSQEL_Q2
32990 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
32992 C...differential cross section for Quasi-Elastic scattering
32993 C. nu + N -> l + N'
32994 C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
32996 C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
32997 C. ENU (GeV) = Neutrino energy
32998 C. Q2 (GeV**2) = (Transfer momentum)**2
33000 C. OUTPUT : DSQEL_Q2 = differential cross section :
33001 C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
33002 C------------------------------------------------------------------
33004 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33007 * particle masses used in qel neutrino scattering modules
33008 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
33009 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
33010 & EMPROTSQ,EMNEUTSQ,EMNSQ
33011 **sr - removed (not needed)
33012 C COMMON /CAXIAL/ FA0, AXIAL2
33016 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
33017 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
33018 DATA AXIAL2 /1.03D0/ ! to be checked
33022 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
33023 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
33024 X = Q2/(EMN*EMN) ! emn=massa barione
33026 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
33027 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
33028 FA = FA0/(1.D0 + Q2/AXIAL2)**2
33032 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
33033 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
33034 A2 = -RM * ((FV1 + FV2)**2 + FFA)
33035 AA = (XA+0.25D0*RM)*(A1 + A2)
33036 BB = -X*FA*(FV1 + FV2)
33037 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
33038 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
33039 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
33040 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
33045 *===prepola============================================================*
33047 CDECK ID>, DT_PREPOLA
33048 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
33050 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33053 c By G. Battistoni and E. Scapparone (sept. 1997)
33055 c Albright & Jarlskog, Nucl Phys B84 (1975) 467
33059 PARAMETER (MAXLND=4000)
33060 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
33062 COMMON /QNPOL/ POLARX(4),PMODUL
33063 * particle masses used in qel neutrino scattering modules
33064 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
33065 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
33066 & EMPROTSQ,EMNEUTSQ,EMNSQ
33067 * steering flags for qel neutrino scattering modules
33068 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
33069 **sr - removed (not needed)
33070 C COMMON /CAXIAL/ FA0, AXIAL2
33071 C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
33072 C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
33074 REAL*8 POL(4,4),BB2(3)
33076 C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
33077 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
33078 **sr uncommented since common block CAXIAL is now commented
33079 DATA AXIAL2 /1.03D0/ ! to be checked
33089 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
33090 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
33091 X = Q2/(EMN*EMN) ! emn=massa barione
33093 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
33094 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
33095 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
33099 FP=2.D0*FA*RMM/(MPI**2 + Q2)
33100 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
33101 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
33102 A2 = -RM * ((FV1 + FV2)**2 + FFA)
33103 AA = (XA+0.25D+00*RM)*(A1 + A2)
33104 BB = -X*FA*(FV1 + FV2)
33105 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
33106 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
33108 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
33110 OMEGA3=2.D+00*FA*(FV1+FV2)
33111 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
33114 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
33115 WW1=2.D+00*OMEGA1*EMN**2
33116 WW2=2.D+00*OMEGA2*EMN**2
33117 WW3=2.D+00*OMEGA3*EMN**2
33118 WW4=2.D+00*OMEGA4*EMN**2
33119 WW5=2.D+00*OMEGA5*EMN**2
33122 BB2(I)=-P(4,I)/P(4,4)
33126 c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
33129 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
33131 * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
33134 c WRITE(*,*) 'Prepola: now in lepton rest frame'
33138 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
33139 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
33140 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
33142 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
33143 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
33145 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
33148 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
33154 PMODUL=PMODUL+POL(4,I)**2
33157 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
33158 IF(NEUDEC.EQ.1) THEN
33159 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
33161 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33163 c Tau has decayed in muon
33166 IF(NEUDEC.EQ.2) THEN
33167 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
33169 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33171 c Tau has decayed in electron
33179 c fill common for muon(electron)
33187 IF(NEUDEC.EQ.1) THEN
33190 ELSEIF(NEUDEC.EQ.2) THEN
33194 ELSEIF(JTYP.EQ.6) THEN
33195 IF(NEUDEC.EQ.1) THEN
33197 ELSEIF(NEUDEC.EQ.2) THEN
33205 c fill common for tau_(anti)neutrino
33215 ELSEIF(JTYP.EQ.6) THEN
33222 c Fill common for muon(electron)_(anti)neutrino
33231 IF(NEUDEC.EQ.1) THEN
33233 ELSEIF(NEUDEC.EQ.2) THEN
33236 ELSEIF(JTYP.EQ.6) THEN
33237 IF(NEUDEC.EQ.1) THEN
33239 ELSEIF(NEUDEC.EQ.2) THEN
33250 c IF(PMODUL.GE.1.D+00) THEN
33251 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
33252 c write(*,*) pmodul
33254 c POL(4,I)=POL(4,I)/PMODUL
33255 c POLARX(I)=POL(4,I)
33259 c PMODUL=PMODUL+POL(4,I)**2
33261 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
33265 c WRITE(*,*) 'PMODUL = ',PMODUL
33269 c WRITE(*,*) 'prepola: Now back to nucl rest frame'
33271 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
33273 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
33274 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
33275 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
33285 *===testrot============================================================*
33287 CDECK ID>, DT_TESTROT
33288 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
33290 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33293 DIMENSION ROT(3,3),PI(3),PO(3)
33295 IF (MODE.EQ.1) THEN
33300 ROT(2,2) = COS(PHI)
33301 ROT(2,3) = -SIN(PHI)
33303 ROT(3,2) = SIN(PHI)
33304 ROT(3,3) = COS(PHI)
33305 ELSEIF (MODE.EQ.2) THEN
33309 ROT(2,1) = COS(PHI)
33311 ROT(2,3) = -SIN(PHI)
33312 ROT(3,1) = SIN(PHI)
33314 ROT(3,3) = COS(PHI)
33315 ELSEIF (MODE.EQ.3) THEN
33319 ROT(1,2) = COS(PHI)
33321 ROT(3,2) = -SIN(PHI)
33322 ROT(1,3) = SIN(PHI)
33324 ROT(3,3) = COS(PHI)
33325 ELSEIF (MODE.EQ.4) THEN
33330 ROT(2,2) = COS(PHI)
33331 ROT(3,2) = -SIN(PHI)
33333 ROT(2,3) = SIN(PHI)
33334 ROT(3,3) = COS(PHI)
33336 STOP ' TESTROT: mode not supported!'
33339 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
33345 *===lepdcyp============================================================*
33347 CDECK ID>, DT_LEPDCYP
33348 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
33349 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33351 C-----------------------------------------------------------------
33353 C Author :- G. Battistoni 10-NOV-1995
33355 C=================================================================
33357 C Purpose : performs decay of polarized lepton in
33358 C its rest frame: a => b + l + anti-nu
33359 C (Example: mu- => nu-mu + e- + anti-nu-e)
33360 C Polarization is assumed along Z-axis
33362 C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
33363 C OF NEGLIGIBLE MASS
33364 C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
33367 C Method : modifies phase space distribution obtained
33368 C by routine EXPLOD using a rejection against the
33369 C matrix element for unpolarized lepton decay
33371 C Inputs : Mass of a : AMA
33374 C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
33377 C Outputs : kinematic variables in the rest frame of decaying lepton
33378 C ETL,PXL,PYL,PZL 4-moment of l
33379 C ETB,PXB,PYB,PZB 4-moment of b
33380 C ETN,PXN,PYN,PZN 4-moment of anti-nu
33382 C============================================================
33386 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33389 PARAMETER ( LINP = 5 ,
33393 PARAMETER ( KALGNM = 2 )
33394 PARAMETER ( ANGLGB = 5.0D-16 )
33395 PARAMETER ( ANGLSQ = 2.5D-31 )
33396 PARAMETER ( AXCSSV = 0.2D+16 )
33397 PARAMETER ( ANDRFL = 1.0D-38 )
33398 PARAMETER ( AVRFLW = 1.0D+38 )
33399 PARAMETER ( AINFNT = 1.0D+30 )
33400 PARAMETER ( AZRZRZ = 1.0D-30 )
33401 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
33402 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
33403 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
33404 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
33405 PARAMETER ( CSNNRM = 2.0D-15 )
33406 PARAMETER ( DMXTRN = 1.0D+08 )
33407 PARAMETER ( ZERZER = 0.D+00 )
33408 PARAMETER ( ONEONE = 1.D+00 )
33409 PARAMETER ( TWOTWO = 2.D+00 )
33410 PARAMETER ( THRTHR = 3.D+00 )
33411 PARAMETER ( FOUFOU = 4.D+00 )
33412 PARAMETER ( FIVFIV = 5.D+00 )
33413 PARAMETER ( SIXSIX = 6.D+00 )
33414 PARAMETER ( SEVSEV = 7.D+00 )
33415 PARAMETER ( EIGEIG = 8.D+00 )
33416 PARAMETER ( ANINEN = 9.D+00 )
33417 PARAMETER ( TENTEN = 10.D+00 )
33418 PARAMETER ( HLFHLF = 0.5D+00 )
33419 PARAMETER ( ONETHI = ONEONE / THRTHR )
33420 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
33421 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
33422 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
33423 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
33424 PARAMETER ( CLIGHT = 2.99792458 D+10 )
33425 PARAMETER ( AVOGAD = 6.0221367 D+23 )
33426 PARAMETER ( AMELGR = 9.1093897 D-28 )
33427 PARAMETER ( PLCKBR = 1.05457266 D-27 )
33428 PARAMETER ( ELCCGS = 4.8032068 D-10 )
33429 PARAMETER ( ELCMKS = 1.60217733 D-19 )
33430 PARAMETER ( AMUGRM = 1.6605402 D-24 )
33431 PARAMETER ( AMMUMU = 0.113428913 D+00 )
33432 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
33433 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
33434 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
33435 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
33436 PARAMETER ( PLABRC = 0.197327053 D+00 )
33437 PARAMETER ( AMELCT = 0.51099906 D-03 )
33438 PARAMETER ( AMUGEV = 0.93149432 D+00 )
33439 PARAMETER ( AMMUON = 0.105658389 D+00 )
33440 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
33441 PARAMETER ( GEVMEV = 1.0 D+03 )
33442 PARAMETER ( EMVGEV = 1.0 D-03 )
33443 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
33444 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
33445 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
33447 C variables for EXPLOD
33449 PARAMETER ( KPMX = 10 )
33450 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
33451 & PZEXPL (KPMX), ETEXPL (KPMX)
33455 **sr - removed (not needed)
33456 C COMMON /GBATNU/ ELERAT,NTRY
33459 C Initializes test variables
33464 C Maximum value for matrix element
33466 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
33467 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
33468 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
33469 C Inputs for EXPLOD
33470 C part. no. 1 is l (e- in mu- decay)
33471 C part. no. 2 is b (nu-mu in mu- decay)
33472 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
33473 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
33480 C phase space distribution
33485 CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
33489 C Calculates matrix element:
33490 C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
33491 C Here CTH is the cosine of the angle between anti-nu and Z axis
33493 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
33495 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
33496 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
33497 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
33498 ELEMAT = 16.D+00 * PROD1 * PROD2
33499 IF(ELEMAT.GT.ELEMAX) THEN
33500 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
33504 C Here performs the rejection
33506 TEST = DT_RNDM(ETOTEX) * ELEMAX
33507 IF ( TEST .GT. ELEMAT ) GO TO 100
33509 C final assignment of variables
33511 ELERAT = ELEMAT/ELEMAX
33527 C==================================================================
33528 C. Generation of Delta resonance events
33529 C==================================================================
33531 *===gen_delta==========================================================*
33533 CDECK ID>, DT_GEN_DELTA
33534 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
33536 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33539 PARAMETER ( LINP = 5 ,
33543 C...Generate a Delta-production neutrino/antineutrino
33544 C. CC-interaction on a nucleon
33546 C. INPUT ENU (GeV) = Neutrino Energy
33547 C. LLEP = neutrino type
33548 C. LTARG = nucleon target type 1=p, 2=n.
33549 C. JINT = 1:CC, 2::NC
33551 C. OUTPUT PPL(4) 4-monentum of final lepton
33552 C----------------------------------------------------
33554 PARAMETER (MAXLND=4000)
33555 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
33557 **sr - removed (not needed)
33558 C COMMON /CBAD/ LBAD, NBAD
33561 DIMENSION PI(3),PO(3)
33562 C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
33563 DIMENSION AML0(6),AMN(2)
33564 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
33565 DATA AMN /0.93827231, 0.93956563/
33566 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
33568 c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
33570 C...Final lepton mass
33571 IF (JINT.EQ.1) THEN
33578 C...Particle labels (LUND)
33586 IF (LTARG .EQ. 1) THEN
33594 IS = -1 + 2*LLEP - 4*K1
33595 LNU = 2 - LLEP + 2*K1
33599 IF (JINT .EQ. 1) THEN ! CC interactions
33603 IF (LTARG .EQ. 1) THEN
33609 IF (LTARG .EQ. 1) THEN
33616 K(3,2) = 23 ! NC (Z0) interactions
33618 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
33619 * Delta0 for neutron (LTARG=2)
33620 C IF (LTARG .EQ. 1) THEN
33625 IF (LTARG .EQ. 1) THEN
33633 C...4-momentum initial lepton
33639 C...4-momentum initial nucleon
33640 P(2,5) = AMN(LTARG)
33651 beta1=-p(2,1)/p(2,4)
33652 beta2=-p(2,2)/p(2,4)
33653 beta3=-p(2,3)/p(2,4)
33656 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
33658 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
33660 phi11=atan(p(1,2)/p(1,3))
33665 CALL DT_TESTROT(PI,Po,PHI11,1)
33667 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33672 phi12=atan(p(1,1)/p(1,3))
33677 CALL DT_TESTROT(Pi,Po,PHI12,2)
33679 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33687 C...Generate the Mass of the Delta
33690 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
33692 IF (NTRY .GT. 1000) THEN
33694 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
33697 IF (AMD .LT. AMDMIN) GOTO 100
33698 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
33699 IF (ENUU .LT. ET) GOTO 100
33701 C...Kinematical limits in Q**2
33702 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
33704 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
33705 ELF = (S - AMD**2 + AML2)/(2.*SQS)
33706 PLF = SQRT(ELF**2 - AML2)
33707 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
33708 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
33709 IF (Q2MIN .LT. 0.) Q2MIN = 0.
33711 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
33712 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
33713 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
33714 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
33716 C...Generate the kinematics of the final particles
33717 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
33718 GAM = EISTAR/AMN(LTARG)
33720 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
33721 EL = GAM*(ELF + BET*PLF*CTSTAR)
33722 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
33723 PL = SQRT(EL**2 - AML2)
33724 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
33725 PHI = 6.28319*PYR(0)
33726 P(4,1) = PLT*COS(PHI)
33727 P(4,2) = PLT*SIN(PHI)
33732 C...4-momentum of Delta
33735 P(5,3) = ENUU-P(4,3)
33736 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
33739 C...4-momentum of intermediate boson
33741 P(3,4) = P(1,4)-P(4,4)
33742 P(3,1) = P(1,1)-P(4,1)
33743 P(3,2) = P(1,2)-P(4,2)
33744 P(3,3) = P(1,3)-P(4,3)
33751 CALL DT_TESTROT(Pi,Po,PHI12,3)
33753 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33760 c********************************************
33766 CALL DT_TESTROT(Pi,Po,PHI11,4)
33768 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33774 c********************************************
33775 C transform back into Lab.
33777 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
33779 C WRITE(6,*)' Lab fram ( fermi incl.) '
33784 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
33787 *===dsigma_delta=======================================================*
33789 CDECK ID>, DT_DSIGMA_DELTA
33790 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
33792 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33795 C...Reaction nu + N -> lepton + Delta
33796 C. returns the cross section
33798 C. INPUT LNU = 1, 2 (neutrino-antineutrino)
33799 C. QQ = t (always negative) GeV**2
33800 C. S = (c.m energy)**2 GeV**2
33801 C. OUTPUT = 10**-38 cm+2/GeV**2
33802 C-----------------------------------------------------
33803 REAL*8 MN, MN2, MN4, MD,MD2, MD4
33805 DATA PI /3.1415926/
33807 GF = (1.1664 * 1.97)
33815 VQ = (MN2 - MD2 - QQ)/2.
33816 VPI = (MN2 + MD2 - QQ)/2.
33817 VK = (S + QQ - MN2 - AML2)/2.
33819 QK = (AML2 - QQ)/2.
33820 PIQ = (QQ + MN2 - MD2)/2.
33822 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
33823 C3 = SQRT(3.)*C3V/MN
33824 C4 = -C3/MD ! attenzione al segno
33825 C5A = 1.18/(1.-QQ/0.4225)**2
33830 IF (LNU .EQ. 1) THEN
33831 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
33832 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
33833 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
33834 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
33835 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
33836 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
33837 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
33838 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
33839 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
33840 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
33841 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
33842 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
33843 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
33844 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
33845 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
33846 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
33847 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
33848 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
33849 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
33850 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
33851 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
33852 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
33853 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
33855 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
33856 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
33857 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
33858 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
33859 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
33860 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
33861 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
33862 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
33863 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
33864 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
33865 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
33866 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
33867 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
33868 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
33869 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
33870 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
33871 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
33872 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
33873 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
33874 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
33875 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
33876 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
33877 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
33881 P1CM = (S-MN2)/(2.*SQRT(S))
33882 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
33887 *===qgaus==============================================================*
33889 CDECK ID>, DT_QGAUS
33890 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
33892 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33895 DIMENSION X(5),W(5)
33896 DATA X/.1488743389D0,.4333953941D0,
33897 & .6794095682D0,.8650633666D0,.9739065285D0
33899 DATA W/.2955242247D0,.2692667193D0,
33900 & .2190863625D0,.1494513491D0,.0666713443D0
33907 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
33908 * DT_DSQEL_Q2(LTYP,ENU,XM-DX))
33915 *===diqbrk=============================================================*
33917 CDECK ID>, DT_DIQBRK
33918 SUBROUTINE DT_DIQBRK
33920 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33925 PARAMETER (NMXHKK=200000)
33927 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
33928 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
33929 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
33930 * extended event history
33931 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
33932 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
33935 COMMON /DTEVNO/ NEVENT,ICASCA
33937 C IF(DT_RNDM(VV).LE.0.5D0)THEN
33938 C CALL GSQBS1(NHKK)
33939 C CALL GSQBS2(NHKK)
33940 C CALL USQBS1(NHKK)
33941 C CALL USQBS2(NHKK)
33942 C CALL GSABS1(NHKK)
33943 C CALL GSABS2(NHKK)
33944 C CALL USABS1(NHKK)
33945 C CALL USABS2(NHKK)
33947 C CALL GSQBS2(NHKK)
33948 C CALL GSQBS1(NHKK)
33949 C CALL USQBS2(NHKK)
33950 C CALL USQBS1(NHKK)
33951 C CALL GSABS2(NHKK)
33952 C CALL GSABS1(NHKK)
33953 C CALL USABS2(NHKK)
33954 C CALL USABS1(NHKK)
33957 IF(DT_RNDM(VV).LE.0.5D0) THEN
33981 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
33982 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
33983 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
33985 C USQBS-2 diagram (split target diquark)
33987 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33990 PARAMETER ( LINP = 5 ,
33996 PARAMETER (NMXHKK=200000)
33998 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
33999 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
34000 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
34001 * extended event history
34002 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
34003 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
34005 * Lorentz-parameters of the current interaction
34006 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
34007 & UMO,PPCM,EPROJ,PPROJ
34008 * diquark-breaking mechanism
34009 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
34012 PARAMETER (NTMHKK= 300)
34013 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34014 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34017 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
34020 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
34021 COMMON /EVFLAG/ NUMEV
34023 C USQBS-2 diagram (split target diquark)
34026 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
34027 C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
34029 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
34030 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34032 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34033 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34034 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34037 C Put new chains into COMMON /HKKTMP/
34042 C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
34046 C IF(NUMEV.EQ.-324)THEN
34047 C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
34048 C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
34049 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34050 C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
34055 C determine x-values of NC1T diquark
34056 XDIQT=PHKK(4,NC1T)*2.D0/UMO
34057 XVQP=PHKK(4,NC1P)*2.D0/UMO
34059 C determine x-values of sea quark pair
34065 IF(ICOU.GE.500)THEN
34068 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
34072 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
34077 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
34078 IF (IPIP.EQ.1) THEN
34079 XQMAX = XDIQT/2.0D0
34080 XAQMAX = 2.D0*XVQP/3.0D0
34082 XQMAX = 2.D0*XVQP/3.0D0
34083 XAQMAX = XDIQT/2.0D0
34085 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
34087 C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
34090 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34093 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34098 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34099 ELSEIF(IPIP.EQ.2)THEN
34100 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34103 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
34104 * XDIQT,XVQP,XSQ,XSAQ
34107 C subtract xsq,xsaq from NC1T diquark and NC1P quark
34113 ELSEIF(IPIP.EQ.2)THEN
34118 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
34120 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34125 IF(IVTHR.EQ.10)THEN
34128 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
34133 XVTHR=XVTHRO/(201-IVTHR)
34136 IF(XVTHR.GT.0.66D0*XDIQT)THEN
34139 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ',
34144 IF(DT_RNDM(V).LT.0.5D0)THEN
34145 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34148 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34152 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
34155 C Prepare 4 momenta of new chains and chain ends
34157 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34158 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34161 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34162 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34163 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34165 C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34166 C * IP1,IP21,IP22,IPP1,IPP2)
34173 ELSEIF(IPIP.EQ.2)THEN
34183 JDAHKT(1,1)=3+IIGLU1
34185 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34186 PHKT(1,1) =PHKK(1,NC2P)
34187 PHKT(2,1) =PHKK(2,NC2P)
34188 PHKT(3,1) =PHKK(3,NC2P)
34189 PHKT(4,1) =PHKK(4,NC2P)
34190 C PHKT(5,1) =PHKK(5,NC2P)
34191 XMIST =(PHKT(4,1)**2-
34192 * PHKT(3,1)**2-PHKT(2,1)**2-
34194 IF(XMIST.GT.0.D0)THEN
34195 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
34198 C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
34201 VHKT(1,1) =VHKK(1,NC2P)
34202 VHKT(2,1) =VHKK(2,NC2P)
34203 VHKT(3,1) =VHKK(3,NC2P)
34204 VHKT(4,1) =VHKK(4,NC2P)
34205 WHKT(1,1) =WHKK(1,NC2P)
34206 WHKT(2,1) =WHKK(2,NC2P)
34207 WHKT(3,1) =WHKK(3,NC2P)
34208 WHKT(4,1) =WHKK(4,NC2P)
34209 C Add here IIGLU1 gluons to this chaina
34214 IF(IIGLU1.GE.1)THEN
34216 DO 61 IIG=2,2+IIGLU1-1
34218 IDHKT(IIG) =IDHKK(KKG)
34222 JDAHKT(1,IIG)=3+IIGLU1
34224 PHKT(1,IIG)=PHKK(1,KKG)
34225 PG1=PG1+ PHKT(1,IIG)
34226 PHKT(2,IIG)=PHKK(2,KKG)
34227 PG2=PG2+ PHKT(2,IIG)
34228 PHKT(3,IIG)=PHKK(3,KKG)
34229 PG3=PG3+ PHKT(3,IIG)
34230 PHKT(4,IIG)=PHKK(4,KKG)
34231 PG4=PG4+ PHKT(4,IIG)
34232 PHKT(5,IIG)=PHKK(5,KKG)
34233 VHKT(1,IIG) =VHKK(1,KKG)
34234 VHKT(2,IIG) =VHKK(2,KKG)
34235 VHKT(3,IIG) =VHKK(3,KKG)
34236 VHKT(4,IIG) =VHKK(4,KKG)
34237 WHKT(1,IIG) =WHKK(1,KKG)
34238 WHKT(2,IIG) =WHKK(2,KKG)
34239 WHKT(3,IIG) =WHKK(3,KKG)
34240 WHKT(4,IIG) =WHKK(4,KKG)
34243 IDHKT(2+IIGLU1) =IP21
34244 ISTHKT(2+IIGLU1) =952
34245 JMOHKT(1,2+IIGLU1)=NC1T
34246 JMOHKT(2,2+IIGLU1)=0
34247 JDAHKT(1,2+IIGLU1)=3+IIGLU1
34248 JDAHKT(2,2+IIGLU1)=0
34249 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
34250 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
34251 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
34252 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
34253 C PHKT(5,2) =PHKK(5,NC1T)
34254 XMIST =(PHKT(4,2+IIGLU1)**2-
34255 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
34256 *PHKT(1,2+IIGLU1)**2)
34257 IF(XMIST.GT.0.D0)THEN
34258 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
34259 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
34260 *PHKT(1,2+IIGLU1)**2)
34262 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
34263 PHKT(5,5+IIGLU1)=0.D0
34265 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
34266 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
34267 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
34268 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
34269 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
34270 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
34271 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
34272 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
34273 IDHKT(3+IIGLU1) =88888
34274 ISTHKT(3+IIGLU1) =95
34275 JMOHKT(1,3+IIGLU1)=1
34276 JMOHKT(2,3+IIGLU1)=2+IIGLU1
34277 JDAHKT(1,3+IIGLU1)=0
34278 JDAHKT(2,3+IIGLU1)=0
34279 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
34280 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
34281 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
34282 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
34284 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
34285 * -PHKT(3,3+IIGLU1)**2)
34286 IF(XMIST.GT.0.D0)THEN
34288 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
34289 * -PHKT(3,3+IIGLU1)**2)
34291 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
34292 PHKT(5,5+IIGLU1)=0.D0
34295 C IF(NUMEV.EQ.-324)THEN
34296 C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
34298 C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
34299 DO 71 IIG=2,2+IIGLU1-1
34300 C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
34301 C & JMOHKT(1,IIG),JMOHKT(2,IIG),
34303 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
34305 C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
34306 C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
34307 C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
34308 C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
34309 C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
34310 C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
34314 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
34315 ELSEIF(IPIP.EQ.2)THEN
34316 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
34318 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
34322 C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
34325 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
34326 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
34327 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
34328 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
34329 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
34330 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
34331 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
34332 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
34334 IDHKT(4+IIGLU1) =-(ISAQ1-6)
34335 ELSEIF(IPIP.EQ.2)THEN
34336 IDHKT(4+IIGLU1) =ISAQ1
34338 ISTHKT(4+IIGLU1) =951
34339 JMOHKT(1,4+IIGLU1)=NC1P
34340 JMOHKT(2,4+IIGLU1)=0
34341 JDAHKT(1,4+IIGLU1)=6+IIGLU1
34342 JDAHKT(2,4+IIGLU1)=0
34343 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34344 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
34345 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
34346 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
34347 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
34348 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
34349 XMIST =(PHKT(4,4+IIGLU1)**2-
34350 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
34351 *PHKT(1,4+IIGLU1)**2)
34352 IF(XMIST.GT.0.D0)THEN
34353 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
34354 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
34355 *PHKT(1,4+IIGLU1)**2)
34357 C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
34358 PHKT(5,4+IIGLU1)=0.D0
34360 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
34361 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
34362 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
34363 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
34364 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
34365 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
34366 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
34367 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
34368 IDHKT(5+IIGLU1) =IP22
34369 ISTHKT(5+IIGLU1) =952
34370 JMOHKT(1,5+IIGLU1)=NC1T
34371 JMOHKT(2,5+IIGLU1)=0
34372 JDAHKT(1,5+IIGLU1)=6+IIGLU1
34373 JDAHKT(2,5+IIGLU1)=0
34374 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
34375 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
34376 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
34377 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
34378 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
34379 XMIST =(PHKT(4,5+IIGLU1)**2-
34380 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
34381 *PHKT(1,5+IIGLU1)**2)
34382 IF(XMIST.GT.0.D0)THEN
34383 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
34384 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
34385 *PHKT(1,5+IIGLU1)**2)
34387 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34388 PHKT(5,5+IIGLU1)=0.D0
34390 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
34391 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
34392 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
34393 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
34394 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
34395 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
34396 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
34397 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
34398 IDHKT(6+IIGLU1) =88888
34399 ISTHKT(6+IIGLU1) =95
34400 JMOHKT(1,6+IIGLU1)=4+IIGLU1
34401 JMOHKT(2,6+IIGLU1)=5+IIGLU1
34402 JDAHKT(1,6+IIGLU1)=0
34403 JDAHKT(2,6+IIGLU1)=0
34404 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
34405 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
34406 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
34407 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
34409 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34410 * -PHKT(3,6+IIGLU1)**2)
34411 IF(XMIST.GT.0.D0)THEN
34413 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34414 * -PHKT(3,6+IIGLU1)**2)
34416 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34417 PHKT(5,5+IIGLU1)=0.D0
34419 C IF(IPIP.GE.2)THEN
34420 C IF(NUMEV.EQ.-324)THEN
34421 C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
34422 C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
34423 C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
34424 C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
34425 C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
34426 C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
34427 C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
34428 C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
34429 C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
34433 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
34434 ELSEIF(IPIP.EQ.2)THEN
34435 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
34437 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
34441 C WRITE(6,*)' MUSQBS1 jump back from chain 6',
34442 C * CHAMAL,PHKT(5,6+IIGLU1)
34445 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
34446 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
34447 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
34448 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
34449 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
34450 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
34451 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
34452 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
34453 C IDHKT(7) =1000*IPP1+100*ISQ+1
34454 IDHKT(7+IIGLU1) =IP1
34455 ISTHKT(7+IIGLU1) =951
34456 JMOHKT(1,7+IIGLU1)=NC1P
34457 JMOHKT(2,7+IIGLU1)=0
34459 C JDAHKT(1,7+IIGLU1)=9+IIGLU1
34460 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
34462 JDAHKT(2,7+IIGLU1)=0
34463 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
34464 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
34465 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
34466 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
34467 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
34468 XMIST =(PHKT(4,7+IIGLU1)**2-
34469 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
34470 *PHKT(1,7+IIGLU1)**2)
34471 IF(XMIST.GT.0.D0)THEN
34472 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
34473 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
34474 *PHKT(1,7+IIGLU1)**2)
34476 C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
34477 PHKT(5,7+IIGLU1)=0.D0
34479 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
34480 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
34481 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
34482 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
34483 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
34484 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
34485 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
34486 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
34487 C Insert here the IIGLU2 gluons
34492 IF(IIGLU2.GE.1)THEN
34494 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
34495 KKG=JJG+IIG-7-IIGLU1
34496 IDHKT(IIG) =IDHKK(KKG)
34500 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
34502 PHKT(1,IIG)=PHKK(1,KKG)
34503 PG1=PG1+ PHKT(1,IIG)
34504 PHKT(2,IIG)=PHKK(2,KKG)
34505 PG2=PG2+ PHKT(2,IIG)
34506 PHKT(3,IIG)=PHKK(3,KKG)
34507 PG3=PG3+ PHKT(3,IIG)
34508 PHKT(4,IIG)=PHKK(4,KKG)
34509 PG4=PG4+ PHKT(4,IIG)
34510 PHKT(5,IIG)=PHKK(5,KKG)
34511 VHKT(1,IIG) =VHKK(1,KKG)
34512 VHKT(2,IIG) =VHKK(2,KKG)
34513 VHKT(3,IIG) =VHKK(3,KKG)
34514 VHKT(4,IIG) =VHKK(4,KKG)
34515 WHKT(1,IIG) =WHKK(1,KKG)
34516 WHKT(2,IIG) =WHKK(2,KKG)
34517 WHKT(3,IIG) =WHKK(3,KKG)
34518 WHKT(4,IIG) =WHKK(4,KKG)
34522 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
34523 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
34524 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
34525 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
34526 ELSEIF(IPIP.EQ.2)THEN
34527 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
34528 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
34529 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
34530 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
34532 ISTHKT(8+IIGLU1+IIGLU2) =952
34533 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
34534 JMOHKT(2,8+IIGLU1+IIGLU2)=0
34535 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
34536 JDAHKT(2,8+IIGLU1+IIGLU2)=0
34537 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
34538 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
34539 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
34540 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
34541 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
34542 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
34543 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
34544 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
34545 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
34546 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
34547 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
34549 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
34550 C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
34555 C PHKT(5,8) =PHKK(5,NC2T)
34556 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
34557 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
34558 *PHKT(1,8+IIGLU1+IIGLU2)**2)
34559 IF(XMIST.GT.0.D0)THEN
34560 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
34561 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
34562 *PHKT(1,8+IIGLU1+IIGLU2)**2)
34564 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34565 PHKT(5,5+IIGLU1)=0.D0
34567 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
34568 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
34569 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
34570 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
34571 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
34572 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
34573 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
34574 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
34575 IDHKT(9+IIGLU1+IIGLU2) =88888
34576 ISTHKT(9+IIGLU1+IIGLU2) =95
34577 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
34578 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
34579 JDAHKT(1,9+IIGLU1+IIGLU2)=0
34580 JDAHKT(2,9+IIGLU1+IIGLU2)=0
34582 C PHKT(1,9+IIGLU1+IIGLU2)
34583 C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
34584 C PHKT(2,9+IIGLU1+IIGLU2)
34585 C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
34586 C PHKT(3,9+IIGLU1+IIGLU2)
34587 C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
34588 C PHKT(4,9+IIGLU1+IIGLU2)
34589 C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
34590 PHKT(1,9+IIGLU1+IIGLU2)
34591 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
34592 PHKT(2,9+IIGLU1+IIGLU2)
34593 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
34594 PHKT(3,9+IIGLU1+IIGLU2)
34595 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
34596 PHKT(4,9+IIGLU1+IIGLU2)
34597 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
34600 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
34601 * -PHKT(2,9+IIGLU1+IIGLU2)**2
34602 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
34603 IF(XMIST.GT.0.D0)THEN
34604 PHKT(5,9+IIGLU1+IIGLU2)
34605 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
34606 * -PHKT(2,9+IIGLU1+IIGLU2)**2
34607 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
34609 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34610 PHKT(5,5+IIGLU1)=0.D0
34613 C IF(NUMEV.EQ.-324)THEN
34614 C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
34615 C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
34616 C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
34617 C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
34618 C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
34620 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
34622 C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
34623 C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
34624 C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
34625 C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
34626 C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
34627 C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
34628 C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
34629 C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
34633 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
34634 ELSEIF(IPIP.EQ.2)THEN
34635 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
34637 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
34641 C WRITE(6,*)' MUSQBS1 jump back from chain 9',
34642 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
34645 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
34646 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
34647 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
34648 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
34649 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
34650 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
34651 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
34652 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
34655 IGCOUN=9+IIGLU1+IIGLU2
34660 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
34661 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34662 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
34664 C GSQBS-2 diagram (split target diquark)
34666 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34669 PARAMETER ( LINP = 5 ,
34675 PARAMETER (NMXHKK=200000)
34677 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
34678 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
34679 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
34680 * extended event history
34681 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
34682 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
34684 * Lorentz-parameters of the current interaction
34685 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
34686 & UMO,PPCM,EPROJ,PPROJ
34687 * diquark-breaking mechanism
34688 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
34691 PARAMETER (NTMHKK= 300)
34692 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34693 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34697 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
34700 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
34702 C GSQBS-2 diagram (split target diquark)
34705 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
34706 C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
34708 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
34709 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34711 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
34712 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34713 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34717 C Put new chains into COMMON /HKKTMP/
34722 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
34725 C IF(IPIP.EQ.2)THEN
34726 C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
34727 C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
34728 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34729 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
34734 C determine x-values of NC1T diquark
34735 XDIQT=PHKK(4,NC1T)*2.D0/UMO
34736 XVQP=PHKK(4,NC1P)*2.D0/UMO
34738 C determine x-values of sea quark pair
34744 IF(ICOU.GE.500)THEN
34748 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
34753 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
34758 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
34759 IF (IPIP.EQ.1) THEN
34760 XQMAX = XDIQT/2.0D0
34761 XAQMAX = 2.D0*XVQP/3.0D0
34763 XQMAX = 2.D0*XVQP/3.0D0
34764 XAQMAX = XDIQT/2.0D0
34766 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
34768 C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
34771 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34774 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34779 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34780 ELSEIF(IPIP.EQ.2)THEN
34781 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34784 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
34785 * XDIQT,XVQP,XSQ,XSAQ
34788 C subtract xsq,xsaq from NC1T diquark and NC1P quark
34794 ELSEIF(IPIP.EQ.2)THEN
34799 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
34801 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34806 IF(IVTHR.EQ.10)THEN
34809 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
34814 XVTHR=XVTHRO/(201-IVTHR)
34817 IF(XVTHR.GT.0.66D0*XDIQT)THEN
34820 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ',
34825 IF(DT_RNDM(V).LT.0.5D0)THEN
34826 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34829 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34833 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
34836 C Prepare 4 momenta of new chains and chain ends
34838 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34839 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34842 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
34843 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34844 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34846 C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34847 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
34854 ELSEIF(IPIP.EQ.2)THEN
34861 C IDHKT(1) =1000*IPP11+100*IPP12+1
34866 IDHKT(4+IIGLU1) =-(ISAQ1-6)
34867 ELSEIF(IPIP.EQ.2)THEN
34868 IDHKT(4+IIGLU1) =ISAQ1
34870 ISTHKT(4+IIGLU1) =961
34871 JMOHKT(1,4+IIGLU1)=NC1P
34872 JMOHKT(2,4+IIGLU1)=0
34873 JDAHKT(1,4+IIGLU1)=6+IIGLU1
34874 JDAHKT(2,4+IIGLU1)=0
34875 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34876 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
34877 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
34878 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
34879 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
34880 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
34881 XXMIST=(PHKT(4,4+IIGLU1)**2-
34882 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
34883 *PHKT(1,4+IIGLU1)**2)
34884 IF(XXMIST.GT.0.D0)THEN
34885 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
34887 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
34889 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
34891 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
34892 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
34893 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
34894 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
34895 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
34896 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
34897 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
34898 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
34899 IDHKT(5+IIGLU1) =IP22
34900 ISTHKT(5+IIGLU1) =962
34901 JMOHKT(1,5+IIGLU1)=NC1T
34902 JMOHKT(2,5+IIGLU1)=0
34903 JDAHKT(1,5+IIGLU1)=6+IIGLU1
34904 JDAHKT(2,5+IIGLU1)=0
34905 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
34906 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
34907 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
34908 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
34909 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
34910 XXMIST=(PHKT(4,5+IIGLU1)**2-
34911 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
34912 *PHKT(1,5+IIGLU1)**2)
34913 IF(XXMIST.GT.0.D0)THEN
34914 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
34916 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
34918 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
34920 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
34921 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
34922 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
34923 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
34924 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
34925 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
34926 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
34927 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
34928 IDHKT(6+IIGLU1) =88888
34929 ISTHKT(6+IIGLU1) =96
34930 JMOHKT(1,6+IIGLU1)=4+IIGLU1
34931 JMOHKT(2,6+IIGLU1)=5+IIGLU1
34932 JDAHKT(1,6+IIGLU1)=0
34933 JDAHKT(2,6+IIGLU1)=0
34934 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
34935 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
34936 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
34937 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
34939 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34940 * -PHKT(3,6+IIGLU1)**2)
34943 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
34944 ELSEIF(IPIP.EQ.2)THEN
34945 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
34947 C---------------------------------------------------
34948 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
34949 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
34950 C we drop chain 6 and give the energy to chain 3
34951 IDHKT(6+IIGLU1)=22888
34953 C WRITE(6,*)' drop chain 6 xgive=1'
34955 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
34956 C we drop chain 6 and give the energy to chain 3
34957 C and change KK11 to IDHKT(5)
34958 IDHKT(6+IIGLU1)=22888
34960 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
34961 KK11=IDHKT(5+IIGLU1)
34963 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
34964 C we drop chain 6 and give the energy to chain 3
34965 C and change KK21 to IDHKT(5+IIGLU1)
34966 C IDHKT(1) =1000*IPP11+100*IPP12+1
34967 IDHKT(6+IIGLU1)=22888
34969 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
34970 KK21=IDHKT(5+IIGLU1)
34972 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
34973 C we drop chain 6 and give the energy to chain 3
34974 C and change KK22 to IDHKT(5)
34975 C IDHKT(1) =1000*IPP11+100*IPP12+1
34976 IDHKT(6+IIGLU1)=22888
34978 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
34979 KK22=IDHKT(5+IIGLU1)
34988 C---------------------------------------------------
34990 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
34991 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
34992 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
34993 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
34994 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
34995 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
34996 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
34997 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
34998 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
35000 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
35001 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
35002 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
35003 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
35004 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
35005 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
35006 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
35007 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
35008 C IDHKT(1) =1000*IPP11+100*IPP12+1
35010 IDHKT(1) =1000*KK21+100*KK22+3
35011 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
35012 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
35013 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
35014 ELSEIF(IPIP.EQ.2)THEN
35015 IDHKT(1) =1000*KK21+100*KK22-3
35016 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
35017 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
35018 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
35023 JDAHKT(1,1)=3+IIGLU1
35025 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
35026 PHKT(1,1) =PHKK(1,NC2P)
35027 *+XGIVE*PHKT(1,4+IIGLU1)
35028 PHKT(2,1) =PHKK(2,NC2P)
35029 *+XGIVE*PHKT(2,4+IIGLU1)
35030 PHKT(3,1) =PHKK(3,NC2P)
35031 *+XGIVE*PHKT(3,4+IIGLU1)
35032 PHKT(4,1) =PHKK(4,NC2P)
35033 *+XGIVE*PHKT(4,4+IIGLU1)
35034 C PHKT(5,1) =PHKK(5,NC2P)
35035 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35037 IF(XXMIST.GT.0.D0)THEN
35038 PHKT(5,1) =SQRT(XXMIST)
35040 WRITE(LOUT,*)'MGSQBS2',XXMIST
35042 PHKT(5,1) =SQRT(XXMIST)
35044 VHKT(1,1) =VHKK(1,NC2P)
35045 VHKT(2,1) =VHKK(2,NC2P)
35046 VHKT(3,1) =VHKK(3,NC2P)
35047 VHKT(4,1) =VHKK(4,NC2P)
35048 WHKT(1,1) =WHKK(1,NC2P)
35049 WHKT(2,1) =WHKK(2,NC2P)
35050 WHKT(3,1) =WHKK(3,NC2P)
35051 WHKT(4,1) =WHKK(4,NC2P)
35052 C Add here IIGLU1 gluons to this chaina
35057 IF(IIGLU1.GE.1)THEN
35059 DO 61 IIG=2,2+IIGLU1-1
35061 IDHKT(IIG) =IDHKK(KKG)
35065 JDAHKT(1,IIG)=3+IIGLU1
35067 PHKT(1,IIG)=PHKK(1,KKG)
35068 PG1=PG1+ PHKT(1,IIG)
35069 PHKT(2,IIG)=PHKK(2,KKG)
35070 PG2=PG2+ PHKT(2,IIG)
35071 PHKT(3,IIG)=PHKK(3,KKG)
35072 PG3=PG3+ PHKT(3,IIG)
35073 PHKT(4,IIG)=PHKK(4,KKG)
35074 PG4=PG4+ PHKT(4,IIG)
35075 PHKT(5,IIG)=PHKK(5,KKG)
35076 VHKT(1,IIG) =VHKK(1,KKG)
35077 VHKT(2,IIG) =VHKK(2,KKG)
35078 VHKT(3,IIG) =VHKK(3,KKG)
35079 VHKT(4,IIG) =VHKK(4,KKG)
35080 WHKT(1,IIG) =WHKK(1,KKG)
35081 WHKT(2,IIG) =WHKK(2,KKG)
35082 WHKT(3,IIG) =WHKK(3,KKG)
35083 WHKT(4,IIG) =WHKK(4,KKG)
35087 IDHKT(2+IIGLU1) =KK11
35088 ISTHKT(2+IIGLU1) =962
35089 JMOHKT(1,2+IIGLU1)=NC1T
35090 JMOHKT(2,2+IIGLU1)=0
35091 JDAHKT(1,2+IIGLU1)=3+IIGLU1
35092 JDAHKT(2,2+IIGLU1)=0
35093 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35094 C * +0.5D0*PHKK(1,NC2T)
35095 *+XGIVE*PHKT(1,5+IIGLU1)
35096 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35097 C *+0.5D0*PHKK(2,NC2T)
35098 *+XGIVE*PHKT(2,5+IIGLU1)
35099 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35100 C *+0.5D0*PHKK(3,NC2T)
35101 *+XGIVE*PHKT(3,5+IIGLU1)
35102 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35103 C *+0.5D0*PHKK(4,NC2T)
35104 *+XGIVE*PHKT(4,5+IIGLU1)
35105 C PHKT(5,2) =PHKK(5,NC1T)
35106 XXMIST=(PHKT(4,2+IIGLU1)**2-
35107 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35108 *PHKT(1,2+IIGLU1)**2)
35109 IF(XXMIST.GT.0.D0)THEN
35110 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
35112 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
35114 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
35116 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
35117 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
35118 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
35119 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
35120 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
35121 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
35122 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
35123 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
35124 IDHKT(3+IIGLU1) =88888
35125 ISTHKT(3+IIGLU1) =96
35126 JMOHKT(1,3+IIGLU1)=1
35127 JMOHKT(2,3+IIGLU1)=2+IIGLU1
35128 JDAHKT(1,3+IIGLU1)=0
35129 JDAHKT(2,3+IIGLU1)=0
35130 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35131 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35132 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35133 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35135 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35136 * -PHKT(3,3+IIGLU1)**2)
35138 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35140 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35141 DO 71 IIG=2,2+IIGLU1-1
35142 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35143 & JMOHKT(1,IIG),JMOHKT(2,IIG),
35145 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35147 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35148 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35149 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35150 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35151 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35152 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35156 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
35157 ELSEIF(IPIP.EQ.2)THEN
35158 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
35160 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35166 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
35167 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
35168 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
35169 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
35170 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
35171 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
35172 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
35173 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
35174 C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
35175 IDHKT(7+IIGLU1) =IP1
35176 ISTHKT(7+IIGLU1) =961
35177 JMOHKT(1,7+IIGLU1)=NC1P
35178 JMOHKT(2,7+IIGLU1)=0
35179 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
35180 JDAHKT(2,7+IIGLU1)=0
35181 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
35182 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
35183 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
35184 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
35185 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
35186 XXMIST=(PHKT(4,7+IIGLU1)**2-
35187 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
35188 *PHKT(1,7+IIGLU1)**2)
35189 IF(XXMIST.GT.0.D0)THEN
35190 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
35192 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
35194 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
35196 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
35197 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
35198 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
35199 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
35200 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
35201 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
35202 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
35203 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
35204 C IDHKT(7) =1000*IPP1+100*ISQ+1
35205 C Insert here the IIGLU2 gluons
35210 IF(IIGLU2.GE.1)THEN
35212 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35213 KKG=JJG+IIG-7-IIGLU1
35214 IDHKT(IIG) =IDHKK(KKG)
35218 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
35220 PHKT(1,IIG)=PHKK(1,KKG)
35221 PG1=PG1+ PHKT(1,IIG)
35222 PHKT(2,IIG)=PHKK(2,KKG)
35223 PG2=PG2+ PHKT(2,IIG)
35224 PHKT(3,IIG)=PHKK(3,KKG)
35225 PG3=PG3+ PHKT(3,IIG)
35226 PHKT(4,IIG)=PHKK(4,KKG)
35227 PG4=PG4+ PHKT(4,IIG)
35228 PHKT(5,IIG)=PHKK(5,KKG)
35229 VHKT(1,IIG) =VHKK(1,KKG)
35230 VHKT(2,IIG) =VHKK(2,KKG)
35231 VHKT(3,IIG) =VHKK(3,KKG)
35232 VHKT(4,IIG) =VHKK(4,KKG)
35233 WHKT(1,IIG) =WHKK(1,KKG)
35234 WHKT(2,IIG) =WHKK(2,KKG)
35235 WHKT(3,IIG) =WHKK(3,KKG)
35236 WHKT(4,IIG) =WHKK(4,KKG)
35240 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
35241 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
35242 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
35243 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
35244 ELSEIF(IPIP.EQ.2)THEN
35246 C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
35247 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
35249 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
35250 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
35251 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
35253 ISTHKT(8+IIGLU1+IIGLU2) =962
35254 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
35255 JMOHKT(2,8+IIGLU1+IIGLU2)=0
35256 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
35257 JDAHKT(2,8+IIGLU1+IIGLU2)=0
35258 C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
35259 C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
35260 C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
35261 C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
35262 PHKT(1,8+IIGLU1+IIGLU2) =
35263 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
35264 PHKT(2,8+IIGLU1+IIGLU2) =
35265 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
35266 PHKT(3,8+IIGLU1+IIGLU2) =
35267 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
35268 PHKT(4,8+IIGLU1+IIGLU2) =
35269 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
35270 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
35271 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
35272 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
35274 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
35279 C PHKT(5,8) =PHKK(5,NC2T)
35280 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
35281 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
35282 *PHKT(1,8+IIGLU1+IIGLU2)**2)
35283 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
35284 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
35285 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
35286 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
35287 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
35288 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
35289 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
35290 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
35291 IDHKT(9+IIGLU1+IIGLU2) =88888
35292 ISTHKT(9+IIGLU1+IIGLU2) =96
35293 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
35294 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
35295 JDAHKT(1,9+IIGLU1+IIGLU2)=0
35296 JDAHKT(2,9+IIGLU1+IIGLU2)=0
35297 PHKT(1,9+IIGLU1+IIGLU2)
35298 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
35299 PHKT(2,9+IIGLU1+IIGLU2)
35300 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
35301 PHKT(3,9+IIGLU1+IIGLU2)
35302 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
35303 PHKT(4,9+IIGLU1+IIGLU2)
35304 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
35305 PHKT(5,9+IIGLU1+IIGLU2)
35306 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
35307 * PHKT(2,9+IIGLU1+IIGLU2)**2
35308 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
35310 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
35311 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
35312 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
35313 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35314 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35315 & JMOHKT(1,IIG),JMOHKT(2,IIG),
35317 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35319 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
35320 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
35321 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
35322 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
35323 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
35324 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
35325 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
35326 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
35330 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
35331 ELSEIF(IPIP.EQ.2)THEN
35332 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
35334 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
35340 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
35341 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
35342 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
35343 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
35344 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
35345 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
35346 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
35347 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
35350 IGCOUN=9+IIGLU1+IIGLU2
35355 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35356 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35357 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35359 C USQBS-1 diagram (split projectile diquark)
35361 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35364 PARAMETER ( LINP = 5 ,
35370 PARAMETER (NMXHKK=200000)
35372 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35373 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35374 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35375 * extended event history
35376 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35377 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35379 * Lorentz-parameters of the current interaction
35380 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35381 & UMO,PPCM,EPROJ,PPROJ
35382 * diquark-breaking mechanism
35383 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35386 PARAMETER (NTMHKK= 300)
35387 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35388 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35391 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35394 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35395 COMMON /EVFLAG/ NUMEV
35397 C USQBS-1 diagram (split projectile diquark)
35399 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
35400 C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
35402 C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
35403 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
35405 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35406 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35407 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35409 C Put new chains into COMMON /HKKTMP/
35414 C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
35418 C IF(NUMEV.EQ.-324)THEN
35419 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35420 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
35421 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35422 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
35427 C determine x-values of NC1P diquark
35428 XDIQP=PHKK(4,NC1P)*2.D0/UMO
35429 XVQT=PHKK(4,NC1T)*2.D0/UMO
35431 C determine x-values of sea quark pair
35437 IF(ICOU.GE.500)THEN
35440 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
35444 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
35449 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35450 IF (IPIP.EQ.1) THEN
35451 XQMAX = XDIQP/2.0D0
35452 XAQMAX = 2.D0*XVQT/3.0D0
35454 XQMAX = 2.D0*XVQT/3.0D0
35455 XAQMAX = XDIQP/2.0D0
35457 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35459 C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
35461 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35464 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35469 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
35470 ELSEIF(IPIP.EQ.2)THEN
35471 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
35474 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
35475 * XDIQP,XVQT,XSQ,XSAQ
35478 C subtract xsq,xsaq from NC1P diquark and NC1T quark
35484 ELSEIF(IPIP.EQ.2)THEN
35489 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
35491 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
35496 IF(IVTHR.EQ.10)THEN
35499 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
35504 XVTHR=XVTHRO/(201-IVTHR)
35507 IF(XVTHR.GT.0.66D0*XDIQP)THEN
35510 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ',
35515 IF(DT_RNDM(V).LT.0.5D0)THEN
35516 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
35519 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
35523 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
35526 C Prepare 4 momenta of new chains and chain ends
35528 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35529 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35531 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35532 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35533 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35539 ELSEIF(IPIP.EQ.2)THEN
35549 JDAHKT(1,1)=3+IIGLU1
35551 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35552 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
35553 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
35554 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
35555 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
35556 C PHKT(5,1) =PHKK(5,NC1P)
35557 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35559 IF(XMIST.GE.0.D0)THEN
35560 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35563 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35566 VHKT(1,1) =VHKK(1,NC1P)
35567 VHKT(2,1) =VHKK(2,NC1P)
35568 VHKT(3,1) =VHKK(3,NC1P)
35569 VHKT(4,1) =VHKK(4,NC1P)
35570 WHKT(1,1) =WHKK(1,NC1P)
35571 WHKT(2,1) =WHKK(2,NC1P)
35572 WHKT(3,1) =WHKK(3,NC1P)
35573 WHKT(4,1) =WHKK(4,NC1P)
35574 C Add here IIGLU1 gluons to this chaina
35579 IF(IIGLU1.GE.1)THEN
35581 DO 61 IIG=2,2+IIGLU1-1
35583 IDHKT(IIG) =IDHKK(KKG)
35587 JDAHKT(1,IIG)=3+IIGLU1
35589 PHKT(1,IIG)=PHKK(1,KKG)
35590 PG1=PG1+ PHKT(1,IIG)
35591 PHKT(2,IIG)=PHKK(2,KKG)
35592 PG2=PG2+ PHKT(2,IIG)
35593 PHKT(3,IIG)=PHKK(3,KKG)
35594 PG3=PG3+ PHKT(3,IIG)
35595 PHKT(4,IIG)=PHKK(4,KKG)
35596 PG4=PG4+ PHKT(4,IIG)
35597 PHKT(5,IIG)=PHKK(5,KKG)
35598 VHKT(1,IIG) =VHKK(1,KKG)
35599 VHKT(2,IIG) =VHKK(2,KKG)
35600 VHKT(3,IIG) =VHKK(3,KKG)
35601 VHKT(4,IIG) =VHKK(4,KKG)
35602 WHKT(1,IIG) =WHKK(1,KKG)
35603 WHKT(2,IIG) =WHKK(2,KKG)
35604 WHKT(3,IIG) =WHKK(3,KKG)
35605 WHKT(4,IIG) =WHKK(4,KKG)
35608 IDHKT(2+IIGLU1) =IPP2
35609 ISTHKT(2+IIGLU1) =932
35610 JMOHKT(1,2+IIGLU1)=NC2T
35611 JMOHKT(2,2+IIGLU1)=0
35612 JDAHKT(1,2+IIGLU1)=3+IIGLU1
35613 JDAHKT(2,2+IIGLU1)=0
35614 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
35615 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
35616 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
35617 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
35618 C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
35619 XMIST=(PHKT(4,2+IIGLU1)**2-
35620 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35621 *PHKT(1,2+IIGLU1)**2)
35622 IF(XMIST.GT.0.D0)THEN
35623 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
35624 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35625 *PHKT(1,2+IIGLU1)**2)
35627 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35628 PHKT(5,2+IIGLU1)=0.D0
35630 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
35631 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
35632 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
35633 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
35634 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
35635 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
35636 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
35637 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
35638 IDHKT(3+IIGLU1) =88888
35639 ISTHKT(3+IIGLU1) =94
35640 JMOHKT(1,3+IIGLU1)=1
35641 JMOHKT(2,3+IIGLU1)=2+IIGLU1
35642 JDAHKT(1,3+IIGLU1)=0
35643 JDAHKT(2,3+IIGLU1)=0
35644 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35645 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35646 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35647 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35649 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35650 * -PHKT(3,3+IIGLU1)**2)
35651 IF(XMIST.GE.0.D0)THEN
35653 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35654 * -PHKT(3,3+IIGLU1)**2)
35656 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35660 C IF(NUMEV.EQ.-324)THEN
35661 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
35662 * JMOHKT(2,1),JDAHKT(1,1),
35663 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35664 DO 71 IIG=2,2+IIGLU1-1
35665 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35666 & JMOHKT(1,IIG),JMOHKT(2,IIG),
35668 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35670 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35671 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35672 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35673 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35674 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35675 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35679 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
35680 ELSEIF(IPIP.EQ.2)THEN
35681 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
35683 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35687 C WRITE(6,*)' MUSQBS1 jump back from chain 3'
35690 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
35691 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
35692 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
35693 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
35694 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
35695 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
35696 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
35697 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
35698 IDHKT(4+IIGLU1) =IP12
35699 ISTHKT(4+IIGLU1) =931
35700 JMOHKT(1,4+IIGLU1)=NC1P
35701 JMOHKT(2,4+IIGLU1)=0
35702 JDAHKT(1,4+IIGLU1)=6+IIGLU1
35703 JDAHKT(2,4+IIGLU1)=0
35704 C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35705 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
35706 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
35707 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
35708 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
35709 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
35710 XMIST =(PHKT(4,4+IIGLU1)**2-
35711 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35712 *PHKT(1,4+IIGLU1)**2)
35713 IF(XMIST.GT.0.D0)THEN
35714 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
35715 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35716 *PHKT(1,4+IIGLU1)**2)
35718 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35719 PHKT(5,4+IIGLU1)=0.D0
35721 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
35722 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
35723 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
35724 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
35725 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
35726 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
35727 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
35728 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
35730 IDHKT(5+IIGLU1) =-(ISAQ1-6)
35731 ELSEIF(IPIP.EQ.2)THEN
35732 IDHKT(5+IIGLU1) =ISAQ1
35734 ISTHKT(5+IIGLU1) =932
35735 JMOHKT(1,5+IIGLU1)=NC1T
35736 JMOHKT(2,5+IIGLU1)=0
35737 JDAHKT(1,5+IIGLU1)=6+IIGLU1
35738 JDAHKT(2,5+IIGLU1)=0
35739 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
35740 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
35741 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
35742 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
35743 C IF( PHKT(4,5).EQ.0.D0)THEN
35748 C PHKT(5,5) =PHKK(5,NC1T)
35749 XMIST=(PHKT(4,5+IIGLU1)**2-
35750 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
35751 *PHKT(1,5+IIGLU1)**2)
35752 IF(XMIST.GT.0.D0)THEN
35753 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
35754 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
35755 *PHKT(1,5+IIGLU1)**2)
35757 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35758 PHKT(5,5+IIGLU1)=0.D0
35760 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
35761 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
35762 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
35763 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
35764 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
35765 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
35766 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
35767 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
35768 IDHKT(6+IIGLU1) =88888
35769 ISTHKT(6+IIGLU1) =94
35770 JMOHKT(1,6+IIGLU1)=4+IIGLU1
35771 JMOHKT(2,6+IIGLU1)=5+IIGLU1
35772 JDAHKT(1,6+IIGLU1)=0
35773 JDAHKT(2,6+IIGLU1)=0
35774 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
35775 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
35776 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
35777 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
35779 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
35780 * -PHKT(3,6+IIGLU1)**2)
35781 IF(XMIST.GE.0.D0)THEN
35783 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
35784 * -PHKT(3,6+IIGLU1)**2)
35786 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35789 C IF(IPIP.EQ.3)THEN
35792 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
35793 ELSEIF(IPIP.EQ.2)THEN
35794 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
35796 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
35800 C WRITE(6,*)' MGSQBS1 jump back from chain 6',
35801 C * CHAMAL,PHKT(5,6+IIGLU1)
35805 C IF(NUMEV.EQ.-324)THEN
35806 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
35807 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
35808 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
35809 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
35810 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
35811 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
35812 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
35813 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
35814 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
35816 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
35817 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
35818 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
35819 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
35820 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
35821 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
35822 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
35823 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
35825 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
35826 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
35827 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
35828 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
35829 ELSEIF(IPIP.EQ.2)THEN
35830 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
35831 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
35832 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
35833 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
35834 C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
35836 ISTHKT(7+IIGLU1) =931
35837 JMOHKT(1,7+IIGLU1)=NC2P
35838 JMOHKT(2,7+IIGLU1)=0
35839 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
35840 JDAHKT(2,7+IIGLU1)=0
35841 C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35842 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
35843 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
35844 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
35845 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
35846 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
35847 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
35848 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
35850 C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
35855 C PHKT(5,7) =PHKK(5,NC2P)
35856 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
35857 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
35858 *PHKT(1,7+IIGLU1)**2)
35859 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
35860 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
35861 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
35862 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
35863 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
35864 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
35865 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
35866 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
35867 C Insert here the IIGLU2 gluons
35872 IF(IIGLU2.GE.1)THEN
35874 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35875 KKG=JJG+IIG-7-IIGLU1
35876 IDHKT(IIG) =IDHKK(KKG)
35880 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
35882 PHKT(1,IIG)=PHKK(1,KKG)
35883 PG1=PG1+ PHKT(1,IIG)
35884 PHKT(2,IIG)=PHKK(2,KKG)
35885 PG2=PG2+ PHKT(2,IIG)
35886 PHKT(3,IIG)=PHKK(3,KKG)
35887 PG3=PG3+ PHKT(3,IIG)
35888 PHKT(4,IIG)=PHKK(4,KKG)
35889 PG4=PG4+ PHKT(4,IIG)
35890 PHKT(5,IIG)=PHKK(5,KKG)
35891 VHKT(1,IIG) =VHKK(1,KKG)
35892 VHKT(2,IIG) =VHKK(2,KKG)
35893 VHKT(3,IIG) =VHKK(3,KKG)
35894 VHKT(4,IIG) =VHKK(4,KKG)
35895 WHKT(1,IIG) =WHKK(1,KKG)
35896 WHKT(2,IIG) =WHKK(2,KKG)
35897 WHKT(3,IIG) =WHKK(3,KKG)
35898 WHKT(4,IIG) =WHKK(4,KKG)
35901 IDHKT(8+IIGLU1+IIGLU2) =IP2
35902 ISTHKT(8+IIGLU1+IIGLU2) =932
35903 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
35904 JMOHKT(2,8+IIGLU1+IIGLU2)=0
35905 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
35906 JDAHKT(2,8+IIGLU1+IIGLU2)=0
35907 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
35908 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
35909 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
35910 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
35911 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
35912 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
35913 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
35914 *PHKT(1,8+IIGLU1+IIGLU2)**2)
35915 IF(XMIST.GT.0.D0)THEN
35916 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
35917 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
35918 *PHKT(1,8+IIGLU1+IIGLU2)**2)
35920 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35921 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
35923 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
35924 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
35925 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
35926 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
35927 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
35928 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
35929 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
35930 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
35931 IDHKT(9+IIGLU1+IIGLU2) =88888
35932 ISTHKT(9+IIGLU1+IIGLU2) =94
35933 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
35934 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
35935 JDAHKT(1,9+IIGLU1+IIGLU2)=0
35936 JDAHKT(2,9+IIGLU1+IIGLU2)=0
35937 PHKT(1,9+IIGLU1+IIGLU2)
35938 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
35939 PHKT(2,9+IIGLU1+IIGLU2)
35940 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
35941 PHKT(3,9+IIGLU1+IIGLU2)
35942 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
35943 PHKT(4,9+IIGLU1+IIGLU2)
35944 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
35946 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
35947 * -PHKT(2,9+IIGLU1+IIGLU2)**2
35948 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
35949 IF(XMIST.GE.0.D0)THEN
35950 PHKT(5,9+IIGLU1+IIGLU2)
35951 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
35952 * -PHKT(2,9+IIGLU1+IIGLU2)**2
35953 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
35955 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35959 C IF(NUMEV.EQ.-324)THEN
35960 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
35961 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
35962 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
35963 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35964 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35965 & JMOHKT(1,IIG),JMOHKT(2,IIG),
35967 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35969 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
35970 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
35971 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
35972 *JDAHKT(1,8+IIGLU1+IIGLU2),
35973 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
35974 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
35975 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
35976 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
35977 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
35981 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
35982 ELSEIF(IPIP.EQ.2)THEN
35983 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
35985 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
35989 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
35990 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
35993 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
35994 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
35995 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
35996 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
35997 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
35998 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
35999 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36000 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36003 IGCOUN=9+IIGLU1+IIGLU2
36007 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36008 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36009 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
36011 C GSQBS-1 diagram (split projectile diquark)
36013 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36016 PARAMETER ( LINP = 5 ,
36022 PARAMETER (NMXHKK=200000)
36024 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36025 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36026 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36027 * extended event history
36028 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36029 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36031 * Lorentz-parameters of the current interaction
36032 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36033 & UMO,PPCM,EPROJ,PPROJ
36034 * diquark-breaking mechanism
36035 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36038 PARAMETER (NTMHKK= 300)
36039 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36040 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36043 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36046 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36048 C GSQBS-1 diagram (split projectile diquark)
36051 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
36052 C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
36054 C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
36055 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
36057 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
36058 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
36059 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
36061 C Put new chains into COMMON /HKKTMP/
36066 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36068 NNNC1=IDHKK(NC1)/1000
36069 MMMC1=IDHKK(NC1)-NNNC1*1000
36071 NNNC2=IDHKK(NC2)/1000
36072 MMMC2=IDHKK(NC2)-NNNC2*1000
36076 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36077 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
36078 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36079 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
36084 C determine x-values of NC1P diquark
36085 XDIQP=PHKK(4,NC1P)*2.D0/UMO
36086 XVQT=PHKK(4,NC1T)*2.D0/UMO
36088 C determine x-values of sea quark pair
36094 IF(ICOU.GE.500)THEN
36097 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
36101 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
36106 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36107 IF (IPIP.EQ.1) THEN
36108 XQMAX = XDIQP/2.0D0
36109 XAQMAX = 2.D0*XVQT/3.0D0
36111 XQMAX = 2.D0*XVQT/3.0D0
36112 XAQMAX = XDIQP/2.0D0
36114 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36116 C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
36119 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36122 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36127 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
36128 ELSEIF(IPIP.EQ.2)THEN
36129 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
36132 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
36133 * XDIQP,XVQT,XSQ,XSAQ
36136 C subtract xsq,xsaq from NC1P diquark and NC1T quark
36142 C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
36145 ELSEIF(IPIP.EQ.2)THEN
36150 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
36152 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
36157 IF(IVTHR.EQ.10)THEN
36160 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
36165 XVTHR=XVTHRO/(201-IVTHR)
36168 IF(XVTHR.GT.0.66D0*XDIQP)THEN
36172 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ',
36177 IF(DT_RNDM(V).LT.0.5D0)THEN
36178 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
36181 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
36185 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
36186 * XVTHR,XDIQP,XVPQI,XVPQII
36189 C Prepare 4 momenta of new chains and chain ends
36191 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36192 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36194 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
36195 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
36196 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
36202 ELSEIF(IPIP.EQ.2)THEN
36209 C IDHKT(2) =1000*IPP21+100*IPP22+1
36213 IDHKT(4+IIGLU1) =IP12
36214 ISTHKT(4+IIGLU1) =921
36215 JMOHKT(1,4+IIGLU1)=NC1P
36216 JMOHKT(2,4+IIGLU1)=0
36217 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36218 JDAHKT(2,4+IIGLU1)=0
36220 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
36221 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
36223 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
36224 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
36225 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
36226 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
36227 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36228 XXMIST=(PHKT(4,4+IIGLU1)**2-
36229 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36230 * PHKT(1,4+IIGLU1)**2)
36231 IF(XXMIST.GT.0.D0)THEN
36232 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36234 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
36236 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36238 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36239 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36240 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36241 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36242 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36243 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36244 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36245 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36247 IDHKT(5+IIGLU1) =-(ISAQ1-6)
36248 ELSEIF(IPIP.EQ.2)THEN
36249 IDHKT(5+IIGLU1) =ISAQ1
36251 ISTHKT(5+IIGLU1) =922
36252 JMOHKT(1,5+IIGLU1)=NC1T
36253 JMOHKT(2,5+IIGLU1)=0
36254 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36255 JDAHKT(2,5+IIGLU1)=0
36257 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
36258 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
36260 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
36261 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
36262 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
36263 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
36264 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36265 XMIST=(PHKT(4,5+IIGLU1)**2-
36266 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36267 *PHKT(1,5+IIGLU1)**2)
36268 IF(XMIST.GT.0.D0)THEN
36269 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
36270 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36271 *PHKT(1,5+IIGLU1)**2)
36273 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36274 PHKT(5,5+IIGLU1)=0.D0
36276 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36277 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36278 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36279 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36280 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36281 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36282 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36283 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36284 IDHKT(6+IIGLU1) =88888
36285 C IDHKT(6) =1000*NNNC1+MMMC1
36286 ISTHKT(6+IIGLU1) =93
36288 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36289 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36290 JDAHKT(1,6+IIGLU1)=0
36291 JDAHKT(2,6+IIGLU1)=0
36292 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36293 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36294 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36295 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36297 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36298 * -PHKT(3,6+IIGLU1)**2)
36301 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
36302 ELSEIF(IPIP.EQ.2)THEN
36303 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
36305 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36306 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36307 C we drop chain 6 and give the energy to chain 3
36308 IDHKT(6+IIGLU1)=33888
36310 C WRITE(6,*)' drop chain 6 xgive=1'
36312 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
36313 C we drop chain 6 and give the energy to chain 3
36314 C and change KK11 to IDHKT(4)
36315 IDHKT(6+IIGLU1)=33888
36317 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
36318 KK11=IDHKT(4+IIGLU1)
36320 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
36321 C we drop chain 6 and give the energy to chain 3
36322 C and change KK21 to IDHKT(4)
36323 C IDHKT(2) =1000*IPP21+100*IPP22+1
36324 IDHKT(6+IIGLU1)=33888
36326 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
36327 KK21=IDHKT(4+IIGLU1)
36329 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
36330 C we drop chain 6 and give the energy to chain 3
36331 C and change KK22 to IDHKT(4)
36332 C IDHKT(2) =1000*IPP21+100*IPP22+1
36333 IDHKT(6+IIGLU1)=33888
36335 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
36336 KK22=IDHKT(4+IIGLU1)
36342 C WRITE(6,*)' MGSQBS1 jump back from chain 6'
36347 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36348 * JMOHKT(1,4+IIGLU1),
36349 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36350 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36351 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36352 * JMOHKT(1,5+IIGLU1),
36353 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36354 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36355 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36356 * JMOHKT(1,6+IIGLU1),
36357 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36358 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36360 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36361 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36362 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36363 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36364 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36365 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36366 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36367 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36373 JDAHKT(1,1)=3+IIGLU1
36375 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
36376 C * +0.5D0*PHKK(1,NC2P)
36377 *+XGIVE*PHKT(1,4+IIGLU1)
36378 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
36379 C * +0.5D0*PHKK(2,NC2P)
36380 *+XGIVE*PHKT(2,4+IIGLU1)
36381 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
36382 C * +0.5D0*PHKK(3,NC2P)
36383 *+XGIVE*PHKT(3,4+IIGLU1)
36384 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
36385 C * +0.5D0*PHKK(4,NC2P)
36386 *+XGIVE*PHKT(4,4+IIGLU1)
36387 C PHKT(5,1) =PHKK(5,NC1P)
36388 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36390 IF(XMIST.GE.0.D0)THEN
36391 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36394 C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
36397 VHKT(1,1) =VHKK(1,NC1P)
36398 VHKT(2,1) =VHKK(2,NC1P)
36399 VHKT(3,1) =VHKK(3,NC1P)
36400 VHKT(4,1) =VHKK(4,NC1P)
36401 WHKT(1,1) =WHKK(1,NC1P)
36402 WHKT(2,1) =WHKK(2,NC1P)
36403 WHKT(3,1) =WHKK(3,NC1P)
36404 WHKT(4,1) =WHKK(4,NC1P)
36405 C Add here IIGLU1 gluons to this chaina
36410 IF(IIGLU1.GE.1)THEN
36412 DO 61 IIG=2,2+IIGLU1-1
36414 IDHKT(IIG) =IDHKK(KKG)
36418 JDAHKT(1,IIG)=3+IIGLU1
36420 PHKT(1,IIG)=PHKK(1,KKG)
36421 PG1=PG1+ PHKT(1,IIG)
36422 PHKT(2,IIG)=PHKK(2,KKG)
36423 PG2=PG2+ PHKT(2,IIG)
36424 PHKT(3,IIG)=PHKK(3,KKG)
36425 PG3=PG3+ PHKT(3,IIG)
36426 PHKT(4,IIG)=PHKK(4,KKG)
36427 PG4=PG4+ PHKT(4,IIG)
36428 PHKT(5,IIG)=PHKK(5,KKG)
36429 VHKT(1,IIG) =VHKK(1,KKG)
36430 VHKT(2,IIG) =VHKK(2,KKG)
36431 VHKT(3,IIG) =VHKK(3,KKG)
36432 VHKT(4,IIG) =VHKK(4,KKG)
36433 WHKT(1,IIG) =WHKK(1,KKG)
36434 WHKT(2,IIG) =WHKK(2,KKG)
36435 WHKT(3,IIG) =WHKK(3,KKG)
36436 WHKT(4,IIG) =WHKK(4,KKG)
36439 C IDHKT(2) =1000*IPP21+100*IPP22+1
36441 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
36442 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
36443 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
36444 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
36445 ELSEIF(IPIP.EQ.2)THEN
36446 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
36447 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
36448 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
36449 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
36451 ISTHKT(2+IIGLU1) =922
36452 JMOHKT(1,2+IIGLU1)=NC2T
36453 JMOHKT(2,2+IIGLU1)=0
36454 JDAHKT(1,2+IIGLU1)=3+IIGLU1
36455 JDAHKT(2,2+IIGLU1)=0
36456 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
36457 *+XGIVE*PHKT(1,5+IIGLU1)
36458 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
36459 *+XGIVE*PHKT(2,5+IIGLU1)
36460 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
36461 *+XGIVE*PHKT(3,5+IIGLU1)
36462 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
36463 *+XGIVE*PHKT(4,5+IIGLU1)
36464 C PHKT(5,2) =PHKK(5,NC2T)
36465 XMIST=(PHKT(4,2+IIGLU1)**2-
36466 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36467 *PHKT(1,2+IIGLU1)**2)
36468 IF(XMIST.GT.0.D0)THEN
36469 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
36470 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36471 *PHKT(1,2+IIGLU1)**2)
36473 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
36474 PHKT(5,2+IIGLU1)=0.D0
36476 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
36477 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
36478 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
36479 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
36480 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
36481 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
36482 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
36483 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
36484 IDHKT(3+IIGLU1) =88888
36485 C IDHKT(3) =1000*NNNC1+MMMC1+10
36486 ISTHKT(3+IIGLU1) =93
36488 JMOHKT(1,3+IIGLU1)=1
36489 JMOHKT(2,3+IIGLU1)=2+IIGLU1
36490 JDAHKT(1,3+IIGLU1)=0
36491 JDAHKT(2,3+IIGLU1)=0
36492 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36493 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36494 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36495 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36497 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36498 * -PHKT(3,3+IIGLU1)**2)
36500 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36502 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36503 DO 71 IIG=2,2+IIGLU1-1
36504 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36505 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36507 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36509 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
36510 & IDHKT(2),JMOHKT(1,2+IIGLU1),
36511 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36512 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36513 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36514 * JMOHKT(1,3+IIGLU1),
36515 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36516 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36520 C IF(IPIP.EQ.1)THEN
36521 C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
36522 C ELSEIF(IPIP.EQ.2)THEN
36523 C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
36526 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
36527 ELSEIF(IPIP.EQ.2)THEN
36528 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
36531 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36535 C WRITE(6,*)' MGSQBS1 jump back from chain 3'
36538 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
36539 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
36540 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
36541 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
36542 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
36543 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
36544 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
36545 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
36547 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
36548 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
36549 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
36550 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
36551 ELSEIF(IPIP.EQ.2)THEN
36552 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
36553 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
36554 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
36555 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
36556 C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
36558 ISTHKT(7+IIGLU1) =921
36559 JMOHKT(1,7+IIGLU1)=NC2P
36560 JMOHKT(2,7+IIGLU1)=0
36561 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36562 JDAHKT(2,7+IIGLU1)=0
36563 C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
36564 C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
36565 C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
36566 C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
36568 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
36569 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
36571 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
36572 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
36573 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
36574 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
36575 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
36576 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
36577 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
36579 C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
36584 C PHKT(5,7) =PHKK(5,NC2P)
36585 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
36586 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36587 *PHKT(1,7+IIGLU1)**2)
36588 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
36589 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
36590 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
36591 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
36592 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
36593 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
36594 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
36595 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36596 C Insert here the IIGLU2 gluons
36601 IF(IIGLU2.GE.1)THEN
36603 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36604 KKG=JJG+IIG-7-IIGLU1
36605 IDHKT(IIG) =IDHKK(KKG)
36609 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36611 PHKT(1,IIG)=PHKK(1,KKG)
36612 PG1=PG1+ PHKT(1,IIG)
36613 PHKT(2,IIG)=PHKK(2,KKG)
36614 PG2=PG2+ PHKT(2,IIG)
36615 PHKT(3,IIG)=PHKK(3,KKG)
36616 PG3=PG3+ PHKT(3,IIG)
36617 PHKT(4,IIG)=PHKK(4,KKG)
36618 PG4=PG4+ PHKT(4,IIG)
36619 PHKT(5,IIG)=PHKK(5,KKG)
36620 VHKT(1,IIG) =VHKK(1,KKG)
36621 VHKT(2,IIG) =VHKK(2,KKG)
36622 VHKT(3,IIG) =VHKK(3,KKG)
36623 VHKT(4,IIG) =VHKK(4,KKG)
36624 WHKT(1,IIG) =WHKK(1,KKG)
36625 WHKT(2,IIG) =WHKK(2,KKG)
36626 WHKT(3,IIG) =WHKK(3,KKG)
36627 WHKT(4,IIG) =WHKK(4,KKG)
36630 IDHKT(8+IIGLU1+IIGLU2) =IP2
36631 ISTHKT(8+IIGLU1+IIGLU2) =922
36632 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
36633 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36634 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36635 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36637 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
36638 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
36640 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
36641 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
36642 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
36643 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
36644 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
36645 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
36646 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36647 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36648 IF(XMIST.GT.0.D0)THEN
36649 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36650 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36651 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36653 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
36654 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
36656 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
36657 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
36658 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
36659 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
36660 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
36661 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
36662 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
36663 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
36664 IDHKT(9+IIGLU1+IIGLU2) =88888
36665 C IDHKT(9) =1000*NNNC2+MMMC2+10
36666 ISTHKT(9+IIGLU1+IIGLU2) =93
36668 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36669 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36670 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36671 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36672 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
36673 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
36674 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
36675 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
36676 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
36677 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
36678 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
36679 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
36680 PHKT(5,9+IIGLU1+IIGLU2)
36681 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36682 * PHKT(2,9+IIGLU1+IIGLU2)**2
36683 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36685 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36686 * JMOHKT(1,7+IIGLU1),
36687 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36688 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36689 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36690 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36691 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36693 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36695 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36696 * IDHKT(8+IIGLU1+IIGLU2),
36697 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
36698 * JDAHKT(1,8+IIGLU1+IIGLU2),
36699 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36700 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36701 * IDHKT(9+IIGLU1+IIGLU2),
36702 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
36703 * JDAHKT(1,9+IIGLU1+IIGLU2),
36704 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36708 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36709 ELSEIF(IPIP.EQ.2)THEN
36710 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36712 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36716 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
36717 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36720 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36721 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36722 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36723 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36724 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36725 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36726 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36727 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36729 IGCOUN=9+IIGLU1+IIGLU2
36734 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36736 SUBROUTINE HKKHKT(I,J)
36737 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36742 PARAMETER (NMXHKK=200000)
36744 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36745 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36746 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36747 * extended event history
36748 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36749 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36752 PARAMETER (NTMHKK= 300)
36753 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36754 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36757 ISTHKK(I) =ISTHKT(J)
36759 C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
36760 IF(IDHKK(I).EQ.88888)THEN
36763 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
36764 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
36766 JMOHKK(1,I)=JMOHKT(1,J)
36767 JMOHKK(2,I)=JMOHKT(2,J)
36769 JDAHKK(1,I)=JDAHKT(1,J)
36770 JDAHKK(2,I)=JDAHKT(2,J)
36771 C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
36773 C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
36776 IF(JDAHKT(1,J).GT.0)THEN
36777 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
36779 PHKK(1,I) =PHKT(1,J)
36780 PHKK(2,I) =PHKT(2,J)
36781 PHKK(3,I) =PHKT(3,J)
36782 PHKK(4,I) =PHKT(4,J)
36783 PHKK(5,I) =PHKT(5,J)
36784 VHKK(1,I) =VHKT(1,J)
36785 VHKK(2,I) =VHKT(2,J)
36786 VHKK(3,I) =VHKT(3,J)
36787 VHKK(4,I) =VHKT(4,J)
36788 WHKK(1,I) =WHKT(1,J)
36789 WHKK(2,I) =WHKT(2,J)
36790 WHKK(3,I) =WHKT(3,J)
36791 WHKK(4,I) =WHKT(4,J)
36795 *===dbreak=============================================================*
36797 CDECK ID>, DT_DBREAK
36798 SUBROUTINE DT_DBREAK(MODE)
36800 ************************************************************************
36801 * This is the steering subroutine for the different diquark breaking *
36804 * MODE = 1 breaking of projectile diquark in qq-q chain using *
36805 * a sea quark (q-qq chain) of the same projectile *
36806 * = 2 breaking of target diquark in q-qq chain using *
36807 * a sea quark (qq-q chain) of the same target *
36808 * = 3 breaking of projectile diquark in qq-q chain using *
36809 * a sea quark (q-aq chain) of the same projectile *
36810 * = 4 breaking of target diquark in q-qq chain using *
36811 * a sea quark (aq-q chain) of the same target *
36812 * = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
36813 * a sea anti-quark (aq-aqaq chain) of the same projectile *
36814 * = 6 breaking of target anti-diquark in aq-aqaq chain using *
36815 * a sea anti-quark (aqaq-aq chain) of the same target *
36816 * = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
36817 * a sea anti-quark (aq-q chain) of the same projectile *
36818 * = 8 breaking of target anti-diquark in aq-aqaq chain using *
36819 * a sea anti-quark (q-aq chain) of the same target *
36821 * Original version by J. Ranft. *
36822 * This version dated 17.5.00 is written by S. Roesler. *
36823 ************************************************************************
36825 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36828 PARAMETER ( LINP = 5 ,
36834 PARAMETER (NMXHKK=200000)
36836 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36837 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36838 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36839 * extended event history
36840 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36841 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36843 * flags for input different options
36844 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
36845 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
36846 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
36847 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
36848 PARAMETER (MAXCHN=10000)
36849 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
36850 * diquark-breaking mechanism
36851 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36852 * flags for particle decays
36853 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
36854 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
36855 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
36858 * chain identifiers
36859 * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
36860 * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
36861 DIMENSION IDCHN1(8),IDCHN2(8)
36862 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
36863 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
36865 * parton identifiers
36866 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
36867 * +-51/52 = unitarity-sea, +-61/62 = gluons )
36868 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
36869 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
36870 & 31, 31, 31, 31, 31, 31, 31, 31,
36871 & 41, 41, 41, 41, 51, 51, 51, 51/
36872 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
36873 & 32, 32, 32, 32, 32, 32, 32, 32,
36874 & 42, 42, 42, 42, 52, 52, 52, 52/
36875 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
36876 & 51, 31, 41, 41, 31, 31, 31, 31,
36877 & 0, 41, 51, 51, 51, 51, 51, 51/
36878 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
36879 & 32, 52, 42, 42, 32, 32, 32, 32,
36880 & 42, 0, 52, 52, 52, 52, 52, 52/
36882 IF (NCHAIN.LE.0) RETURN
36885 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
36886 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
36887 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
36889 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
36890 & (IS1P.EQ.ISP1P(MODE,3)))
36892 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
36893 & (IS1T.EQ.ISP1T(MODE,3)))
36897 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
36898 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
36899 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
36901 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
36902 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
36904 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
36905 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
36907 * find mother nucleons of the diquark to be splitted and of the
36908 * sea-quark and reject this combination if it is not the same
36909 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
36910 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
36915 IDXMO1 = JMOHKK(IANCES,IDX1)
36917 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
36918 & (JMOHKK(2,IDXMO1).NE.0)) THEN
36923 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
36924 IDXMO1 = JMOHKK(IANC,IDXMO1)
36927 IDXMO2 = JMOHKK(IANCES,IDX2)
36929 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
36930 & (JMOHKK(2,IDXMO2).NE.0)) THEN
36935 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
36936 IDXMO2 = JMOHKK(IANC,IDXMO2)
36939 IF (IDXMO1.NE.IDXMO2) GOTO 2
36940 * quark content of projectile parton
36941 IP1 = IDHKK(JMOHKK(1,IDX1))
36943 IP12 = (IP1-1000*IP11)/100
36944 IP2 = IDHKK(JMOHKK(2,IDX1))
36946 IP22 = (IP2-1000*IP21)/100
36947 * quark content of target parton
36948 IT1 = IDHKK(JMOHKK(1,IDX2))
36950 IT12 = (IT1-1000*IT11)/100
36951 IT2 = IDHKK(JMOHKK(2,IDX2))
36953 IT22 = (IT2-1000*IT21)/100
36954 * split diquark and form new chains
36955 IF (MODE.EQ.1) THEN
36956 IF (IT1.EQ.4) GOTO 2
36957 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36958 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36959 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
36960 ELSEIF (MODE.EQ.2) THEN
36961 IF (IT2.EQ.4) GOTO 2
36962 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36963 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36964 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
36965 ELSEIF (MODE.EQ.3) THEN
36966 IF (IT1.EQ.4) GOTO 2
36967 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36968 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36969 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
36970 ELSEIF (MODE.EQ.4) THEN
36971 IF (IT2.EQ.4) GOTO 2
36972 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36973 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36974 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
36975 ELSEIF (MODE.EQ.5) THEN
36976 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36977 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36978 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
36979 ELSEIF (MODE.EQ.6) THEN
36980 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36981 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36982 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
36983 ELSEIF (MODE.EQ.7) THEN
36984 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36985 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36986 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
36987 ELSEIF (MODE.EQ.8) THEN
36988 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36989 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36990 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
36992 IF (IREJ.GE.1) THEN
36993 if ((ipq.lt.0).or.(ipq.ge.4))
36994 & write(LOUT,*) 'ipq !!!',ipq,mode
36995 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
36996 * accept or reject new chains corresponding to PDBSEA
36998 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
36999 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
37000 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
37001 ELSEIF (IPQ.EQ.3) THEN
37002 ACC = DBRKA(3,MODE)
37003 REJ = DBRKR(3,MODE)
37005 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
37008 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
37009 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
37012 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
37015 * new chains have been accepted and are now copied into HKKEVT
37016 IF (IACC.EQ.1) THEN
37018 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
37019 & PHKK(3,IDX1),PHKK(4,IDX1),
37021 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
37022 & PHKK(3,IDX2),PHKK(4,IDX2),
37025 IDHKK(IDX1) = 99888
37026 IDHKK(IDX2) = 99888
37031 CALL HKKHKT(NHKK,K)
37032 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
37037 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
37042 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
37044 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
37056 *===cqpair=============================================================*
37058 CDECK ID>, DT_CQPAIR
37059 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
37061 ************************************************************************
37062 * This subroutine Creates a Quark-antiquark PAIR from the sea. *
37064 * XQMAX maxium energy fraction of quark (input) *
37065 * XAQMAX maxium energy fraction of antiquark (input) *
37066 * XQ energy fraction of quark (output) *
37067 * XAQ energy fraction of antiquark (output) *
37068 * IFLV quark flavour (- antiquark flavor) (output) *
37070 * This version dated 14.5.00 is written by S. Roesler. *
37071 ************************************************************************
37073 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37076 PARAMETER ( LINP = 5 ,
37080 * Lorentz-parameters of the current interaction
37081 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37082 & UMO,PPCM,EPROJ,PPROJ
37089 * sample quark flavour
37091 * set seasq here (the one from DTCHAI should be used in the future)
37093 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
37095 * sample energy fractions of sea pair
37096 * we first sample the energy fraction of a gluon and then split the gluon
37098 * maximum energy fraction of the gluon forced via input
37099 XGMAXI = XQMAX+XAQMAX
37100 * minimum energy fraction of the gluon
37101 XTHR1 = 4.0D0 /UMO**2
37102 XTHR2 = 0.54D0/UMO**1.5D0
37103 XGMIN = MAX(XTHR1,XTHR2)
37104 * maximum energy fraction of the gluon
37106 XGMAX = MIN(XGMAXI,XGMAX)
37107 IF (XGMIN.GE.XGMAX) THEN
37112 * sample energy fraction of the gluon
37116 IF (NLOOP.GE.50) THEN
37120 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
37121 EGLUON = XGLUON*UMO/2.0D0
37123 * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
37124 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
37127 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
37129 IF (RQ.LT.0.5D0) THEN
37136 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1