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)
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/ppLHC.inp'
262 OPEN(UNIT=7,FILE=FILNAM,STATUS='OLD')
263 OPEN(UNIT=14,FILE="nuclear.bin",STATUS='OLD')
264 * OPEN(UNIT=6,FILE="dpm.out",STATUS='UNKNOWN')
266 READ(7,'(A78)',END=9999) CLINE
268 IF (CLINE(1:1).EQ.'*') THEN
270 C WRITE(LOUT,'(A78)') CLINE
273 C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
274 C1000 FORMAT(A10,6E10.0,A8)
278 READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
279 1006 FORMAT(A10,A60,A8)
280 READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
282 WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
283 1001 FORMAT(A10,6G10.3,A8)
287 * check for valid control card and get card index
290 IF (CODEWD.EQ.CODE(I)) ICW = I
293 WRITE(LOUT,1002) CODEWD
294 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
5633 IDHKK(NHKK) = IDT_IPDGHA(ID)
5635 PHKK(4,NHKK) = AAM(ID)
5636 PHKK(5,NHKK) = AAM(ID)
5639 C IF (IDHKK(NHKK).EQ.22) THEN
5640 C PHKK(4,NHKK) = AAM(33)
5641 C PHKK(5,NHKK) = AAM(33)
5646 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5653 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5654 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5656 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5657 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5658 VHKK(4,NHKK) = 0.0D0
5659 WHKK(4,NHKK) = 0.0D0
5662 * balance Fermi-momenta
5663 IF (NMASS.GE.2) THEN
5667 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5669 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5670 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5677 *===fer4m==============================================================*
5680 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5682 ************************************************************************
5683 * Sampling of nucleon Fermi-momenta from distributions at T=0. *
5684 * processed by S. Roesler, 17.10.95 *
5685 ************************************************************************
5687 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5690 PARAMETER ( LINP = 5 ,
5696 * particle properties (BAMJET index convention)
5698 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5699 & IICH(210),IIBAR(210),K1(210),K2(210)
5702 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5703 & EBINDP(2),EBINDN(2),EPOT(2,210),
5704 & ETACOU(2),ICOUL,LFERMI
5706 DATA LSTART /.TRUE./
5712 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
5716 CALL DT_DFERMI(PABS)
5718 C IF (PABS.GE.PBIND) THEN
5720 C IF (MOD(ILOOP,500).EQ.0) THEN
5721 C WRITE(LOUT,1001) PABS,PBIND,ILOOP
5722 C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
5723 C & ' energy ',2E12.3,I6)
5727 CALL DT_DPOLI(POLC,POLS)
5728 CALL DT_DSFECF(SFE,CFE)
5732 ET = SQRT(PABS*PABS+AAM(KT)**2)
5746 *===nuc2cm=============================================================*
5748 CDECK ID>, DT_NUC2CM
5749 SUBROUTINE DT_NUC2CM
5751 ************************************************************************
5752 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
5753 * nucl. cms. (This subroutine replaces NUCMOM.) *
5754 * This version dated 15.01.95 is written by S. Roesler *
5755 ************************************************************************
5757 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5760 PARAMETER ( LINP = 5 ,
5764 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5768 PARAMETER (NMXHKK=200000)
5770 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5771 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5772 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5773 * extended event history
5774 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5775 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5778 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5779 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5781 * properties of photon/lepton projectiles
5782 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5783 * particle properties (BAMJET index convention)
5785 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5786 & IICH(210),IIBAR(210),K1(210),K2(210)
5787 * Glauber formalism: collision properties
5788 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5789 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5791 * statistics: Glauber-formalism
5792 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5804 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5805 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5806 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5808 C IF (IDHKK(I).EQ.22) THEN
5816 C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5817 C & PX,PY,PZ,PE,IDB,MODE)
5818 IF (PHKK(5,I).GT.ZERO) THEN
5819 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5820 & PX,PY,PZ,PE,IDBAM(I),MODE)
5830 C IF (ID.EQ.22) ID = 113
5831 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5832 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5833 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5837 NWTACC = MAX(NWAACC,NWBACC)
5841 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5849 *===splptn=============================================================*
5851 CDECK ID>, DT_SPLPTN
5852 SUBROUTINE DT_SPLPTN(NN)
5854 ************************************************************************
5855 * SamPLing of ParToN momenta and flavors. *
5856 * This version dated 15.01.95 is written by S. Roesler *
5857 ************************************************************************
5859 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5862 PARAMETER ( LINP = 5 ,
5866 * Lorentz-parameters of the current interaction
5867 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5868 & UMO,PPCM,EPROJ,PPROJ
5870 * sample flavors of sea-quarks
5871 CALL DT_SPLFLA(NN,1)
5873 * sample x-values of partons at chain ends
5875 CALL DT_XKSAMP(NN,ECM)
5878 CALL DT_SPLFLA(NN,2)
5883 *===splfla=============================================================*
5885 CDECK ID>, DT_SPLFLA
5886 SUBROUTINE DT_SPLFLA(NN,MODE)
5888 ************************************************************************
5889 * SamPLing of FLAvors of partons at chain ends. *
5890 * This subroutine replaces FLKSAA/FLKSAM. *
5891 * NN number of nucleon-nucleon interactions *
5892 * MODE = 1 sea-flavors *
5893 * = 2 valence-flavors *
5894 * Based on the original version written by J. Ranft/H.-J. Moehring. *
5895 * This version dated 16.01.95 is written by S. Roesler *
5896 ************************************************************************
5898 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5901 PARAMETER ( LINP = 5 ,
5905 PARAMETER ( MAXNCL = 260,
5908 & MAXSQU = 20*MAXVQU,
5909 & MAXINT = MAXVQU+MAXSQU)
5910 * flavors of partons (DTUNUC 1.x)
5911 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5912 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5913 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5914 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5915 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5916 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5917 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5918 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5919 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5920 & IXPV,IXPS,IXTV,IXTS,
5921 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5922 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5923 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5924 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5925 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5926 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5927 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5928 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5929 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5930 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5931 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5932 * particle properties (BAMJET index convention)
5934 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5935 & IICH(210),IIBAR(210),K1(210),K2(210)
5936 * various options for treatment of partons (DTUNUC 1.x)
5937 * (chain recombination, Cronin,..)
5938 LOGICAL LCO2CR,LINTPT
5939 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5945 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5949 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5952 ELSEIF (MODE.EQ.2) THEN
5955 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5958 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5965 *===getptn=============================================================*
5967 CDECK ID>, DT_GETPTN
5968 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5970 ************************************************************************
5971 * This subroutine collects partons at chain ends from temporary *
5972 * commons and puts them into DTEVT1. *
5973 * This version dated 15.01.95 is written by S. Roesler *
5974 ************************************************************************
5976 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5979 PARAMETER ( LINP = 5 ,
5983 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5987 PARAMETER ( MAXNCL = 260,
5990 & MAXSQU = 20*MAXVQU,
5991 & MAXINT = MAXVQU+MAXSQU)
5994 PARAMETER (NMXHKK=200000)
5996 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5997 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5998 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5999 * extended event history
6000 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6001 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6003 * flags for input different options
6004 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6005 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6006 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6007 * auxiliary common for chain system storage (DTUNUC 1.x)
6008 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6010 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6011 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6013 * flags for diffractive interactions (DTUNUC 1.x)
6014 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6015 * x-values of partons (DTUNUC 1.x)
6016 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6017 & XTVQ(MAXVQU),XTVD(MAXVQU),
6018 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
6019 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
6020 * flavors of partons (DTUNUC 1.x)
6021 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6022 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6023 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6024 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6025 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6026 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6027 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6028 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6029 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6030 & IXPV,IXPS,IXTV,IXTS,
6031 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6032 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6033 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6034 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6035 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6036 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6037 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6038 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6039 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6040 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6041 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6043 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6045 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6053 IF (ISKPCH(1,I).EQ.99) GOTO 10
6054 ICCHAI(1,1) = ICCHAI(1,1)+2
6057 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6058 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6060 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6061 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6062 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6063 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6065 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6066 & +(PP1(3)+PT1(3))**2)
6068 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6069 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6070 & +(PP2(3)+PT2(3))**2)
6072 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6073 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6076 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6077 C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6078 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6081 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6083 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6084 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6085 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6086 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6087 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6089 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6091 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6093 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6100 IF (ISKPCH(2,I).EQ.99) GOTO 20
6101 ICCHAI(1,2) = ICCHAI(1,2)+2
6104 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6105 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6107 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6108 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6109 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6110 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6112 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6113 & +(PP1(3)+PT1(3))**2)
6115 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6116 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6117 & +(PP2(3)+PT2(3))**2)
6119 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6120 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6123 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6124 C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6125 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6128 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6130 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6131 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6132 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6133 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6134 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6136 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6138 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6140 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6147 IF (ISKPCH(3,I).EQ.99) GOTO 30
6148 ICCHAI(1,3) = ICCHAI(1,3)+2
6151 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6152 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6154 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6155 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6156 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6157 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6159 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6160 & +(PP1(3)+PT1(3))**2)
6162 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6163 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6164 & +(PP2(3)+PT2(3))**2)
6166 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6167 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6170 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6171 C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6172 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6175 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6177 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6178 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6179 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6180 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6181 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6183 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6185 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6187 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6192 * disea-valence chains
6194 IF (ISKPCH(5,I).EQ.99) GOTO 50
6195 ICCHAI(1,5) = ICCHAI(1,5)+2
6198 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6199 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6201 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6202 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6203 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6204 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6206 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6207 & +(PP1(3)+PT1(3))**2)
6209 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6210 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6211 & +(PP2(3)+PT2(3))**2)
6213 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6214 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6217 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6218 C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6219 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6222 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6224 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6225 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6226 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6227 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6228 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6230 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6232 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6234 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6239 * valence-sea chains
6241 IF (ISKPCH(6,I).EQ.99) GOTO 60
6242 ICCHAI(1,6) = ICCHAI(1,6)+2
6245 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6246 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6248 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6249 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6250 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6251 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6253 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6254 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6255 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6256 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6257 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6259 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6261 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6263 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6265 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6267 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6268 & +(PP1(3)+PT1(3))**2)
6270 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6271 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6272 & +(PP2(3)+PT2(3))**2)
6274 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6276 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6278 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6280 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6282 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6284 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6285 & +(PP1(3)+PT2(3))**2)
6287 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6288 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6289 & +(PP2(3)+PT1(3))**2)
6291 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6293 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6296 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6297 C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6298 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6301 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6306 * sea-valence chains
6308 IF (ISKPCH(4,I).EQ.99) GOTO 40
6309 ICCHAI(1,4) = ICCHAI(1,4)+2
6312 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6313 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6315 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6316 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6317 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6318 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6320 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6321 & +(PP1(3)+PT1(3))**2)
6323 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6324 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6325 & +(PP2(3)+PT2(3))**2)
6327 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6328 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6331 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6332 C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6333 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6336 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6338 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6339 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6340 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6341 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6342 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6344 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6346 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6348 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6353 * valence-disea chains
6355 IF (ISKPCH(7,I).EQ.99) GOTO 70
6356 ICCHAI(1,7) = ICCHAI(1,7)+2
6359 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6360 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6362 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6363 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6364 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6365 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6367 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6368 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6369 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6370 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6371 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6373 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6375 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6377 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6379 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6381 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6382 & +(PP1(3)+PT1(3))**2)
6384 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6385 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6386 & +(PP2(3)+PT2(3))**2)
6388 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6390 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6392 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6394 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6396 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6398 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6399 & +(PP1(3)+PT2(3))**2)
6401 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6402 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6403 & +(PP2(3)+PT1(3))**2)
6405 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6407 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6410 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6411 C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6412 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6415 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6420 * valence-valence chains
6422 IF (ISKPCH(8,I).EQ.99) GOTO 80
6423 ICCHAI(1,8) = ICCHAI(1,8)+2
6426 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6427 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6429 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6430 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6431 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6432 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6434 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6435 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6436 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6437 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6439 * check for diffractive event
6441 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6442 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6444 PP(K) = PP1(K)+PP2(K)
6445 PT(K) = PT1(K)+PT2(K)
6448 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6449 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6450 C IF (IREJ1.NE.0) GOTO 9999
6451 IF (IREJ1.NE.0) THEN
6459 IF (IDIFF.EQ.0) THEN
6460 * valence-valence chain system
6461 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6464 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6465 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6466 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6467 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6468 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6469 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6470 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6471 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6472 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6473 & +(PP1(3)+PT1(3))**2)
6475 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6476 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6477 & +(PP2(3)+PT2(3))**2)
6479 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6482 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6483 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6484 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6485 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6486 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6487 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6488 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6489 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6490 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6491 & +(PP1(3)+PT2(3))**2)
6493 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6494 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6495 & +(PP2(3)+PT1(3))**2)
6497 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6499 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6502 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6503 C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6504 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6507 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6512 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6514 * energy-momentum & flavor conservation check
6515 IF (ABS(IDIFF).NE.1) THEN
6516 IF (IDIFF.NE.0) THEN
6517 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6520 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6536 *===chkcsy=============================================================*
6538 CDECK ID>, DT_CHKCSY
6539 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6541 ************************************************************************
6542 * CHeCk Chain SYstem for consistency of partons at chain ends. *
6543 * ID1,ID2 PDG-numbers of partons at chain ends *
6544 * LCHK = .true. consistent chain *
6545 * = .false. inconsistent chain *
6546 * This version dated 18.01.95 is written by S. Roesler *
6547 ************************************************************************
6549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6552 PARAMETER ( LINP = 5 ,
6561 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6562 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6563 * q-qq, aq-aqaq chain
6564 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6565 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6566 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6568 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6569 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6575 *===eventa=============================================================*
6577 CDECK ID>, DT_EVENTA
6578 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6580 ************************************************************************
6581 * Treatment of nucleon-nucleon interactions in a two-chain *
6583 * (input) ID BAMJET-index of projectile hadron (in case of *
6585 * IP/IT mass number of projectile/target nucleus *
6586 * NCSY number of two chain systems *
6587 * IREJ rejection flag *
6588 * This version dated 15.01.95 is written by S. Roesler *
6589 ************************************************************************
6591 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6594 PARAMETER ( LINP = 5 ,
6598 PARAMETER (TINY10=1.0D-10)
6602 PARAMETER (NMXHKK=200000)
6604 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6605 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6606 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6607 * extended event history
6608 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6609 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6612 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6613 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6614 & IREXCI(3),IRDIFF(2),IRINC
6615 * flags for diffractive interactions (DTUNUC 1.x)
6616 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6617 * particle properties (BAMJET index convention)
6619 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6620 & IICH(210),IIBAR(210),K1(210),K2(210)
6621 * flags for input different options
6622 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6623 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6624 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6625 * various options for treatment of partons (DTUNUC 1.x)
6626 * (chain recombination, Cronin,..)
6627 LOGICAL LCO2CR,LINTPT
6628 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6631 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6636 * skip following treatment for low-mass diffraction
6637 IF (ABS(IFLAGD).EQ.1) THEN
6638 NPOINT(3) = NPOINT(2)
6642 * multiple scattering of chain ends
6643 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6644 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6647 * get a two-chain system from DTEVT1
6655 PT1(K) = PHKK(K,NC+1)
6656 PP2(K) = PHKK(K,NC+2)
6657 PT2(K) = PHKK(K,NC+3)
6663 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6664 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6665 IF (IREJ1.GT.0) THEN
6667 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6673 * meson/antibaryon projectile:
6674 * sample single-chain valence-valence systems (Reggeon contrib.)
6675 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6676 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6679 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6680 * check DTEVT1 for remaining resonance mass corrections
6681 CALL DT_EVTRES(IREJ1)
6682 IF (IREJ1.GT.0) THEN
6683 IRRES(1) = IRRES(1)+1
6684 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6689 * assign p_t to two-"chain" systems consisting of two resonances only
6690 * since only entries for chains will be affected, this is obsolete
6691 * in case of JETSET-fragmetation
6694 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6695 IF (LCO2CR) CALL DT_COM2CR
6699 * fragmentation of the complete event
6700 **uncomment for internal phojet-fragmentation
6701 C CALL DT_EVTFRA(IREJ1)
6702 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6703 IF (IREJ1.GT.0) THEN
6705 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6709 * decay of possible resonances (should be obsolete)
6720 *===getcsy=============================================================*
6722 CDECK ID>, DT_GETCSY
6723 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6724 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6726 ************************************************************************
6727 * This version dated 15.01.95 is written by S. Roesler *
6728 ************************************************************************
6730 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6733 PARAMETER ( LINP = 5 ,
6737 PARAMETER (TINY10=1.0D-10)
6741 PARAMETER (NMXHKK=200000)
6743 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6744 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6745 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6746 * extended event history
6747 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6748 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6751 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6752 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6753 & IREXCI(3),IRDIFF(2),IRINC
6754 * flags for input different options
6755 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6756 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6757 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6758 * flags for diffractive interactions (DTUNUC 1.x)
6759 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6761 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6762 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6766 * get quark content of partons
6773 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6774 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6775 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6776 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6777 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6778 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6779 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6780 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6782 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6784 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6785 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6787 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6788 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6790 * store initial configuration for energy-momentum cons. check
6791 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6793 * sample intrinsic p_t at chain-ends
6794 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6795 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6796 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6797 IF (IREJ1.NE.0) THEN
6798 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6803 C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6804 C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6805 C* check second chain for resonance
6806 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6807 C & AMCH2,AMCH2N,IDCH2,IREJ1)
6808 C IF (IREJ1.NE.0) GOTO 9999
6809 C IF (IDR2.NE.0) THEN
6810 C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6811 C & AMCH2,AMCH2N,AMCH1,IREJ1)
6812 C IF (IREJ1.NE.0) GOTO 9999
6814 C* check first chain for resonance
6815 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6816 C & AMCH1,AMCH1N,IDCH1,IREJ1)
6817 C IF (IREJ1.NE.0) GOTO 9999
6818 C IF (IDR1.NE.0) IDR1 = 100*IDR1
6820 C* check first chain for resonance
6821 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6822 C & AMCH1,AMCH1N,IDCH1,IREJ1)
6823 C IF (IREJ1.NE.0) GOTO 9999
6824 C IF (IDR1.NE.0) THEN
6825 C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6826 C & AMCH1,AMCH1N,AMCH2,IREJ1)
6827 C IF (IREJ1.NE.0) GOTO 9999
6829 C* check second chain for resonance
6830 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6831 C & AMCH2,AMCH2N,IDCH2,IREJ1)
6832 C IF (IREJ1.NE.0) GOTO 9999
6833 C IF (IDR2.NE.0) IDR2 = 100*IDR2
6837 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6838 * check chains for resonances
6839 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6840 & AMCH1,AMCH1N,IDCH1,IREJ1)
6841 IF (IREJ1.NE.0) GOTO 9999
6842 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6843 & AMCH2,AMCH2N,IDCH2,IREJ1)
6844 IF (IREJ1.NE.0) GOTO 9999
6845 * change kinematics corresponding to resonance-masses
6846 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6847 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6848 & AMCH1,AMCH1N,AMCH2,IREJ1)
6849 IF (IREJ1.GT.0) GOTO 9999
6850 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6851 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6852 & AMCH2,AMCH2N,IDCH2,IREJ1)
6853 IF (IREJ1.NE.0) GOTO 9999
6854 IF (IDR2.NE.0) IDR2 = 100*IDR2
6855 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6856 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6857 & AMCH2,AMCH2N,AMCH1,IREJ1)
6858 IF (IREJ1.GT.0) GOTO 9999
6859 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6860 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6861 & AMCH1,AMCH1N,IDCH1,IREJ1)
6862 IF (IREJ1.NE.0) GOTO 9999
6863 IF (IDR1.NE.0) IDR1 = 100*IDR1
6864 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6865 AMDIF1 = ABS(AMCH1-AMCH1N)
6866 AMDIF2 = ABS(AMCH2-AMCH2N)
6867 IF (AMDIF2.LT.AMDIF1) THEN
6868 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6869 & AMCH2,AMCH2N,AMCH1,IREJ1)
6870 IF (IREJ1.GT.0) GOTO 9999
6871 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6872 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6873 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6874 IF (IREJ1.NE.0) GOTO 9999
6875 IF (IDR1.NE.0) IDR1 = 100*IDR1
6877 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6878 & AMCH1,AMCH1N,AMCH2,IREJ1)
6879 IF (IREJ1.GT.0) GOTO 9999
6880 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6881 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6882 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6883 IF (IREJ1.NE.0) GOTO 9999
6884 IF (IDR2.NE.0) IDR2 = 100*IDR2
6889 * store final configuration for energy-momentum cons. check
6891 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6892 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6893 IF (IREJ1.NE.0) GOTO 9999
6896 * put partons and chains into DTEVT1
6898 PCH1(I) = PP1(I)+PT1(I)
6899 PCH2(I) = PP2(I)+PT2(I)
6901 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6902 & PP1(3),PP1(4),0,0,0)
6903 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6904 & PT1(3),PT1(4),0,0,0)
6905 KCH = 100+IDCH(MOP1)*10+1
6906 CALL DT_EVTPUT(KCH,88888,-2,-1,
6907 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6908 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6909 & PP2(3),PP2(4),0,0,0)
6910 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6911 & PT2(3),PT2(4),0,0,0)
6913 CALL DT_EVTPUT(KCH,88888,-2,-1,
6914 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6919 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6920 * "cancel" sea-sea chains
6921 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6922 IF (IREJ1.NE.0) GOTO 9998
6923 **sr 16.5. flag for EVENTB
6932 *===chkine=============================================================*
6934 CDECK ID>, DT_CHKINE
6935 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6936 & AMCH1,AMCH1N,AMCH2,IREJ)
6938 ************************************************************************
6939 * This subroutine replaces CORMOM. *
6940 * This version dated 05.01.95 is written by S. Roesler *
6941 ************************************************************************
6943 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6946 PARAMETER ( LINP = 5 ,
6950 PARAMETER (TINY10=1.0D-10)
6952 * flags for input different options
6953 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6954 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6955 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6957 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6958 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6959 & IREXCI(3),IRDIFF(2),IRINC
6961 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6962 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6967 SCALE = AMCH1N/MAX(AMCH1,TINY10)
6973 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6974 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6975 PP1(I) = SCALE*PP1(I)
6976 PT1(I) = SCALE*PT1(I)
6978 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6979 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6982 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6983 & (PP2(3)+PT2(3))**2 )
6984 AMCH22 = (ECH-PCH)*(ECH+PCH)
6985 IF (AMCH22.LT.0.0D0) THEN
6987 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6992 AMCH2 = SQRT(AMCH22)
6994 * put partons again on mass shell
6998 IF (JMSHL.EQ.1) THEN
7004 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7005 IF (IREJ1.NE.0) THEN
7006 IF (JMSHL.EQ.0) GOTO 9998
7018 IF (JMSHL.EQ.1) THEN
7024 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7025 IF (IREJ1.NE.0) THEN
7026 IF (JMSHL.EQ.0) GOTO 9998
7042 9997 IRCHKI(1) = IRCHKI(1)+1
7048 9998 IRCHKI(2) = IRCHKI(2)+1
7051 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7056 *===ch2res=============================================================*
7058 CDECK ID>, DT_CH2RES
7059 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7060 & AM,AMN,IMODE,IREJ)
7062 ************************************************************************
7063 * Check chains for resonance production. *
7064 * This subroutine replaces COMCMA/COBCMA/COMCM2 *
7066 * IF1,2,3,4 input flavors (q,aq in any order) *
7068 * MODE = 1 check q-aq chain for meson-resonance *
7069 * = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7070 * = 3 check qq-aqaq chain for lower mass cut *
7072 * IDR = 0 no resonances found *
7073 * = -1 pseudoscalar meson/octet baryon *
7074 * = 1 vector-meson/decuplet baryon *
7075 * IDXR BAMJET-index of corresponding resonance *
7076 * AMN mass of corresponding resonance *
7078 * IREJ rejection flag *
7079 * This version dated 06.01.95 is written by S. Roesler *
7080 ************************************************************************
7082 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7085 PARAMETER ( LINP = 5 ,
7089 * particle properties (BAMJET index convention)
7091 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7092 & IICH(210),IIBAR(210),K1(210),K2(210)
7093 * quark-content to particle index conversion (DTUNUC 1.x)
7094 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7095 & IA08(6,21),IA10(6,21)
7097 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7098 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7099 & IREXCI(3),IRDIFF(2),IRINC
7100 * flags for input different options
7101 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7102 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7103 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7105 DIMENSION IF(4),JF(4)
7108 C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7109 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7111 C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7115 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7116 WRITE(LOUT,1000) MODE
7117 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7118 & 1X,' program stopped')
7127 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7128 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7136 IF (IF(I).NE.0) THEN
7141 IF (NF.LE.MODE) THEN
7142 WRITE(LOUT,1001) MODE,IF
7143 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7144 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7150 * check for meson resonance
7154 IF (JF(2).GT.0) THEN
7158 IFPS = IMPS(IFAQ,IFQ)
7159 IFV = IMVE(IFAQ,IFQ)
7163 IF (AMX.LT.AMV) THEN
7164 IF (AMX.LT.AMPS) THEN
7165 IF (IMODE.GT.0) THEN
7166 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7168 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7172 * replace chain by pseudoscalar meson
7176 ELSEIF (AMX.LT.AMHI) THEN
7177 * replace chain by vector-meson
7184 * check for baryon resonance
7186 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7190 IF (AMX.LT.AM10) THEN
7191 IF (AMX.LT.AM8) THEN
7192 IF (IMODE.GT.0) THEN
7193 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7195 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7199 * replace chain by oktet baryon
7203 ELSEIF (AMX.LT.AMHI) THEN
7210 * check qq-aqaq for lower mass cut
7212 * empirical definition of AMHI to allow for (b-antib)-pair prod.
7214 IF (AMX.LT.AMHI) GOTO 9999
7218 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7219 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7221 IRRES(2) = IRRES(2)+1
7225 *===rjseac=============================================================*
7227 CDECK ID>, DT_RJSEAC
7228 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7230 ************************************************************************
7231 * ReJection of SEA-sea Chains. *
7232 * MOP1/2 entries of projectile sea-partons in DTEVT1 *
7233 * MOT1/2 entries of projectile sea-partons in DTEVT1 *
7234 * This version dated 16.01.95 is written by S. Roesler *
7235 ************************************************************************
7237 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7240 PARAMETER ( LINP = 5 ,
7244 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7248 PARAMETER (NMXHKK=200000)
7250 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7251 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7252 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7253 * extended event history
7254 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7255 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7258 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7259 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7262 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7266 * projectile sea q-aq-pair
7267 * indices of sea-pair
7270 * index of mother-nucleon
7271 IDXNUC(1) = JMOHKK(1,MOP1)
7272 * status of valence quarks to be corrected
7275 * target sea q-aq-pair
7276 * indices of sea-pair
7279 * index of mother-nucleon
7280 IDXNUC(2) = JMOHKK(1,MOT1)
7281 * status of valence quarks to be corrected
7286 DO 2 I=NPOINT(2),NHKK
7287 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7288 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7289 * valence parton found
7290 * inrease 4-momentum by sea 4-momentum
7292 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7293 & PHKK(K,IDXSEA(N,2))
7295 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7296 & PHKK(2,I)**2-PHKK(3,I)**2))
7299 ISTHKK(IDXSEA(N,J)) = 100
7300 IDHKK(IDXSEA(N,J)) = 0
7301 JMOHKK(1,IDXSEA(N,J)) = 0
7302 JMOHKK(2,IDXSEA(N,J)) = 0
7303 JDAHKK(1,IDXSEA(N,J)) = 0
7304 JDAHKK(2,IDXSEA(N,J)) = 0
7306 PHKK(K,IDXSEA(N,J)) = ZERO
7307 VHKK(K,IDXSEA(N,J)) = ZERO
7308 WHKK(K,IDXSEA(N,J)) = ZERO
7310 PHKK(5,IDXSEA(N,J)) = ZERO
7315 IF (IDONE.NE.1) THEN
7316 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7317 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7318 & '-record!',/,1X,' sea-quark pairs ',
7319 & 2I5,4X,2I5,' could not be canceled!')
7331 *===vv2sch=============================================================*
7333 CDECK ID>, DT_VV2SCH
7334 SUBROUTINE DT_VV2SCH
7336 ************************************************************************
7337 * Change Valence-Valence chain systems to Single CHain systems for *
7338 * hadron-nucleus collisions with meson or antibaryon projectile. *
7339 * (Reggeon contribution) *
7340 * The single chain system is approximately treated as one chain and a *
7342 * This version dated 18.01.95 is written by S. Roesler *
7343 ************************************************************************
7345 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7348 PARAMETER ( LINP = 5 ,
7352 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7358 PARAMETER (NMXHKK=200000)
7360 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7361 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7362 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7363 * extended event history
7364 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7365 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7367 * flags for input different options
7368 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7369 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7370 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7372 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7373 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7376 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7379 DATA LSTART /.TRUE./
7384 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7385 & 'valence chains treated')
7391 * get index of first chain
7392 DO 1 I=NPOINT(3),NHKK
7393 IF (IDHKK(I).EQ.88888) THEN
7400 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7401 & .AND.(NC.LT.NSTOP)) THEN
7402 * get valence-valence chains
7403 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7404 * get "mother"-hadron indices
7405 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7406 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7407 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7408 KTARG = IDT_ICIHAD(IDHKK(MO2))
7409 * Lab momentum of projectile hadron
7410 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7411 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7414 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7415 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7417 * single chain requested
7418 * get flavors of chain-end partons
7419 MO(1) = JMOHKK(1,NC)
7420 MO(2) = JMOHKK(2,NC)
7421 MO(3) = JMOHKK(1,NC+3)
7422 MO(4) = JMOHKK(2,NC+3)
7424 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7426 IF (ABS(IDHKK(MO(I))).GE.1000)
7427 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7429 * which one is the q-aq chain?
7430 * N1,N1+1 - DTEVT1-entries for q-aq system
7431 * N2,N2+1 - DTEVT1-entries for the other chain
7432 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7437 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7447 PT1(K) = PHKK(K,N1+1)
7449 PT2(K) = PHKK(K,N2+1)
7451 AMCH1 = PHKK(5,N1+2)
7452 AMCH2 = PHKK(5,N2+2)
7453 * get meson-identity corresponding to flavors of q-aq chain
7456 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7457 & ZERO,AMCH1N,1,IDUM)
7459 * change kinematics of chains
7460 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7461 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7462 & AMCH1,AMCH1N,AMCH2,IREJ1)
7463 IF (IREJ1.NE.0) GOTO 10
7464 * check second chain for resonance
7466 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7467 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7468 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7469 IF (IREJ1.NE.0) GOTO 10
7470 IF (IDR2.NE.0) IDR2 = 100*IDR2
7471 * add partons and chains to DTEVT1
7473 PCH1(K) = PP1(K)+PT1(K)
7474 PCH2(K) = PP2(K)+PT2(K)
7476 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7477 & PP1(3),PP1(4),0,0,0)
7478 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7479 & PT1(2),PT1(3),PT1(4),0,0,0)
7480 KCH = ISTHKK(N1+2)+100
7481 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7482 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7484 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7485 & PP2(3),PP2(4),0,0,0)
7486 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7487 & PT2(2),PT2(3),PT2(4),0,0,0)
7488 KCH = ISTHKK(N2+2)+100
7489 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7490 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7506 *=== phnsch ===========================================================*
7508 CDECK ID>, DT_PHNSCH
7509 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7511 *----------------------------------------------------------------------*
7513 * Probability for Hadron Nucleon Single CHain interactions: *
7515 * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7518 * Last change on 04-jan-94 by Alfredo Ferrari *
7520 * modified by J.R.for use in DTUNUC 6.1.94 *
7522 * Input variables: *
7523 * Kp = hadron projectile index (Part numbering *
7525 * Ktarg = target nucleon index (1=proton, 8=neutron) *
7526 * Plab = projectile laboratory momentum (GeV/c) *
7527 * Output variable: *
7528 * Phnsch = probability per single chain (particle *
7529 * exchange) interactions *
7531 *----------------------------------------------------------------------*
7533 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7536 PARAMETER ( LUNOUT = 6 )
7537 PARAMETER ( LUNERR = 6 )
7538 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7539 PARAMETER ( ZERZER = 0.D+00 )
7540 PARAMETER ( ONEONE = 1.D+00 )
7541 PARAMETER ( TWOTWO = 2.D+00 )
7542 PARAMETER ( FIVFIV = 5.D+00 )
7543 PARAMETER ( HLFHLF = 0.5D+00 )
7545 PARAMETER ( NALLWP = 39 )
7546 PARAMETER ( IDMAXP = 210 )
7548 DIMENSION ICHRGE(39),AM(39)
7550 * particle properties (BAMJET index convention)
7552 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7553 & IICH(210),IIBAR(210),K1(210),K2(210)
7555 DIMENSION KPTOIP(210)
7556 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7557 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7558 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7559 & IQTCHR(-6:6),MQUARK(3,39)
7561 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7562 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7564 SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7565 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7566 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7567 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7569 * Conversion from part to paprop numbering
7570 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7571 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7572 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7574 * 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7575 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7576 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7577 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7579 * 1st reaction: gamma p total
7580 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7581 * 2nd reaction: gamma d total
7582 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7583 * 3rd reaction: pi+ p total
7584 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7585 * 4th reaction: pi- p total
7586 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7587 * 5th reaction: pi+/- d total
7588 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7589 * 6th reaction: K+ p total
7590 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7591 * 7th reaction: K+ n total
7592 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7593 * 8th reaction: K+ d total
7594 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7595 * 9th reaction: K- p total
7596 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7597 * 10th reaction: K- n total
7598 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7599 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7601 * 11th reaction: K- d total
7602 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7603 * 12th reaction: p p total
7604 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7605 * 13th reaction: p n total
7606 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7607 * 14th reaction: p d total
7608 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
7609 * 15th reaction: pbar p total
7610 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
7611 * 16th reaction: pbar n total
7612 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
7613 * 17th reaction: pbar d total
7614 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
7615 * 18th reaction: Lamda p total
7616 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
7617 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7619 * 19th reaction: pi+ p elastic
7620 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
7621 * 20th reaction: pi- p elastic
7622 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
7623 * 21st reaction: K+ p elastic
7624 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
7625 * 22nd reaction: K- p elastic
7626 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
7627 * 23rd reaction: p p elastic
7628 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
7629 * 24th reaction: p d elastic
7630 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
7631 * 25th reaction: pbar p elastic
7632 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
7633 * 26th reaction: pbar p elastic bis
7634 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
7635 * 27th reaction: pbar n elastic
7636 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
7637 * 28th reaction: Lamda p elastic
7638 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
7639 * 29th reaction: K- p ela bis
7640 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
7641 * 30th reaction: pi- p cx
7642 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
7643 * 31st reaction: K- p cx
7644 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
7645 * 32nd reaction: K+ n cx
7646 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
7647 * 33rd reaction: pbar p cx
7648 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
7650 * +-------------------------------------------------------------------*
7651 ICHRGE(KTARG)=IICH(KTARG)
7652 AM (KTARG)=AAM (KTARG)
7653 * | Check for pi0 (d-dbar)
7654 IF ( KP .NE. 26 ) THEN
7660 * +-------------------------------------------------------------------*
7667 * +-------------------------------------------------------------------*
7668 * +-------------------------------------------------------------------*
7669 * | No such interactions for baryon-baryon
7670 IF ( IIBAR (KP) .GT. 0 ) THEN
7674 * +-------------------------------------------------------------------*
7675 * | No "annihilation" diagram possible for K+ p/n
7676 ELSE IF ( IP .EQ. 15 ) THEN
7680 * +-------------------------------------------------------------------*
7681 * | No "annihilation" diagram possible for K0 p/n
7682 ELSE IF ( IP .EQ. 24 ) THEN
7686 * +-------------------------------------------------------------------*
7687 * | No "annihilation" diagram possible for Omebar p/n
7688 ELSE IF ( IP .GE. 38 ) THEN
7693 * +-------------------------------------------------------------------*
7694 * +-------------------------------------------------------------------*
7695 * | If the momentum is larger than 50 GeV/c, compute the single
7696 * | chain probability at 50 GeV/c and extrapolate to the present
7697 * | momentum according to 1/sqrt(s)
7698 * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7699 * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7700 * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7701 * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7703 * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7704 IF ( PLAB .GT. 50.D+00 ) THEN
7707 AMTSQ = AM (KTARG)**2
7708 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7709 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7710 EPROJ = SQRT ( PLA**2 + AMPSQ )
7711 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7712 UMORAT = SQRT ( UMOSQ / UMO50 )
7714 * +-------------------------------------------------------------------*
7716 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7719 AMTSQ = AM (KTARG)**2
7720 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7721 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7722 EPROJ = SQRT ( PLA**2 + AMPSQ )
7723 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7724 UMORAT = SQRT ( UMOSQ / UMO50 )
7726 * +-------------------------------------------------------------------*
7733 * +-------------------------------------------------------------------*
7735 * +-------------------------------------------------------------------*
7737 IF ( IHLP (IP) .EQ. 2 ) THEN
7743 * | Compute the pi+ p total cross section:
7744 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7746 ACOF = SGTCOE (1,19)
7747 BCOF = SGTCOE (2,19)
7748 ENNE = SGTCOE (3,19)
7749 CCOF = SGTCOE (4,19)
7750 DCOF = SGTCOE (5,19)
7751 * | Compute the pi+ p elastic cross section:
7752 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7754 * | Compute the pi+ p inelastic cross section:
7755 SPPPIN = SPPPTT - SPPPEL
7761 * | Compute the pi- p total cross section:
7762 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7764 ACOF = SGTCOE (1,20)
7765 BCOF = SGTCOE (2,20)
7766 ENNE = SGTCOE (3,20)
7767 CCOF = SGTCOE (4,20)
7768 DCOF = SGTCOE (5,20)
7769 * | Compute the pi- p elastic cross section:
7770 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7772 * | Compute the pi- p inelastic cross section:
7773 SPMPIN = SPMPTT - SPMPEL
7774 SIGDIA = SPMPIN - SPPPIN
7775 * | +----------------------------------------------------------------*
7776 * | | Charged pions: besides isospin consideration it is supposed
7777 * | | that (pi+ n)el is almost equal to (pi- p)el
7778 * | | and (pi+ p)el " " " " (pi- n)el
7779 * | | and all are almost equal among each others
7780 * | | (reasonable above 5 GeV/c)
7781 IF ( ICHRGE (IP) .NE. 0 ) THEN
7783 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7784 ACOF = SGTCOE (1,JREAC)
7785 BCOF = SGTCOE (2,JREAC)
7786 ENNE = SGTCOE (3,JREAC)
7787 CCOF = SGTCOE (4,JREAC)
7788 DCOF = SGTCOE (5,JREAC)
7789 * | | Compute the total cross section:
7790 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7792 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7793 ACOF = SGTCOE (1,JREAC)
7794 BCOF = SGTCOE (2,JREAC)
7795 ENNE = SGTCOE (3,JREAC)
7796 CCOF = SGTCOE (4,JREAC)
7797 DCOF = SGTCOE (5,JREAC)
7798 * | | Compute the elastic cross section:
7799 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7801 * | | Compute the inelastic cross section:
7802 SHNCIN = SHNCTT - SHNCEL
7803 * | | Number of diagrams:
7804 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7805 * | | Now compute the chain end (anti)quark-(anti)diquark
7806 IQFSC1 = 1 + IP - 13
7809 IQBSC2 = 1 + IP - 13
7811 * | +----------------------------------------------------------------*
7812 * | | pi0: besides isospin consideration it is supposed that the
7813 * | | elastic cross section is not very different from
7814 * | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
7817 K2HLP = ( KP - 23 ) / 3
7818 * | | Number of diagrams:
7819 * | | For u ubar (k2hlp=0):
7820 * NDIAGR = 2 - KHELP
7821 * | | For d dbar (k2hlp=1):
7822 * NDIAGR = 2 + KHELP - K2HLP
7823 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7824 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7825 * | | Now compute the chain end (anti)quark-(anti)diquark
7832 * | +----------------------------------------------------------------*
7834 * +-------------------------------------------------------------------*
7836 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7842 * | Compute the K+ p total cross section:
7843 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7845 ACOF = SGTCOE (1,21)
7846 BCOF = SGTCOE (2,21)
7847 ENNE = SGTCOE (3,21)
7848 CCOF = SGTCOE (4,21)
7849 DCOF = SGTCOE (5,21)
7850 * | Compute the K+ p elastic cross section:
7851 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7853 * | Compute the K+ p inelastic cross section:
7854 SKPPIN = SKPPTT - SKPPEL
7860 * | Compute the K- p total cross section:
7861 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7863 ACOF = SGTCOE (1,22)
7864 BCOF = SGTCOE (2,22)
7865 ENNE = SGTCOE (3,22)
7866 CCOF = SGTCOE (4,22)
7867 DCOF = SGTCOE (5,22)
7868 * | Compute the K- p elastic cross section:
7869 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7871 * | Compute the K- p inelastic cross section:
7872 SKMPIN = SKMPTT - SKMPEL
7873 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7874 * | +----------------------------------------------------------------*
7875 * | | Charged Kaons: actually only K-
7876 IF ( ICHRGE (IP) .NE. 0 ) THEN
7878 * | | +-------------------------------------------------------------*
7879 * | | | Proton target:
7880 IF ( KHELP .EQ. 0 ) THEN
7882 * | | | Number of diagrams:
7885 * | | +-------------------------------------------------------------*
7886 * | | | Neutron target: besides isospin consideration it is supposed
7887 * | | | that (K- n)el is almost equal to (K- p)el
7888 * | | | (reasonable above 5 GeV/c)
7890 ACOF = SGTCOE (1,10)
7891 BCOF = SGTCOE (2,10)
7892 ENNE = SGTCOE (3,10)
7893 CCOF = SGTCOE (4,10)
7894 DCOF = SGTCOE (5,10)
7895 * | | | Compute the total cross section:
7896 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7898 * | | | Compute the elastic cross section:
7900 * | | | Compute the inelastic cross section:
7901 SHNCIN = SHNCTT - SHNCEL
7902 * | | | Number of diagrams:
7906 * | | +-------------------------------------------------------------*
7907 * | | Now compute the chain end (anti)quark-(anti)diquark
7913 * | +----------------------------------------------------------------*
7914 * | | K0's: (actually only K0bar)
7917 * | | +-------------------------------------------------------------*
7918 * | | | Proton target: (K0bar p)in supposed to be given by
7919 * | | | (K- p)in - Sig_diagr
7920 IF ( KHELP .EQ. 0 ) THEN
7921 SHNCIN = SKMPIN - SIGDIA
7922 * | | | Number of diagrams:
7925 * | | +-------------------------------------------------------------*
7926 * | | | Neutron target: (K0bar n)in supposed to be given by
7927 * | | | (K- n)in + Sig_diagr
7928 * | | | besides isospin consideration it is supposed
7929 * | | | that (K- n)el is almost equal to (K- p)el
7930 * | | | (reasonable above 5 GeV/c)
7932 ACOF = SGTCOE (1,10)
7933 BCOF = SGTCOE (2,10)
7934 ENNE = SGTCOE (3,10)
7935 CCOF = SGTCOE (4,10)
7936 DCOF = SGTCOE (5,10)
7937 * | | | Compute the total cross section:
7938 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7940 * | | | Compute the elastic cross section:
7942 * | | | Compute the inelastic cross section:
7943 SHNCIN = SHNCTT - SHNCEL + SIGDIA
7944 * | | | Number of diagrams:
7948 * | | +-------------------------------------------------------------*
7949 * | | Now compute the chain end (anti)quark-(anti)diquark
7956 * | +----------------------------------------------------------------*
7958 * +-------------------------------------------------------------------*
7960 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7961 * | For momenta between 3 and 5 GeV/c the use of tabulated data
7962 * | should be implemented!
7963 ACOF = SGTCOE (1,15)
7964 BCOF = SGTCOE (2,15)
7965 ENNE = SGTCOE (3,15)
7966 CCOF = SGTCOE (4,15)
7967 DCOF = SGTCOE (5,15)
7968 * | Compute the pbar p total cross section:
7969 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7971 IF ( PLA .LT. FIVFIV ) THEN
7976 ACOF = SGTCOE (1,JREAC)
7977 BCOF = SGTCOE (2,JREAC)
7978 ENNE = SGTCOE (3,JREAC)
7979 CCOF = SGTCOE (4,JREAC)
7980 DCOF = SGTCOE (5,JREAC)
7981 * | Compute the pbar p elastic cross section:
7982 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7984 * | Compute the pbar p inelastic cross section:
7985 SAPPIN = SAPPTT - SAPPEL
7986 ACOF = SGTCOE (1,12)
7987 BCOF = SGTCOE (2,12)
7988 ENNE = SGTCOE (3,12)
7989 CCOF = SGTCOE (4,12)
7990 DCOF = SGTCOE (5,12)
7991 * | Compute the p p total cross section:
7992 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7994 ACOF = SGTCOE (1,23)
7995 BCOF = SGTCOE (2,23)
7996 ENNE = SGTCOE (3,23)
7997 CCOF = SGTCOE (4,23)
7998 DCOF = SGTCOE (5,23)
7999 * | Compute the p p elastic cross section:
8000 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8002 * | Compute the K- p inelastic cross section:
8003 SPPINE = SPPTOT - SPPELA
8004 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8006 * | +----------------------------------------------------------------*
8008 IF ( ICHRGE (IP) .NE. 0 ) THEN
8010 * | | +-------------------------------------------------------------*
8011 * | | | Proton target:
8012 IF ( KHELP .EQ. 0 ) THEN
8013 * | | | Number of diagrams:
8017 * | | +-------------------------------------------------------------*
8018 * | | | Neutron target: it is supposed that (ap n)el is almost equal
8019 * | | | to (ap p)el (reasonable above 5 GeV/c)
8021 ACOF = SGTCOE (1,16)
8022 BCOF = SGTCOE (2,16)
8023 ENNE = SGTCOE (3,16)
8024 CCOF = SGTCOE (4,16)
8025 DCOF = SGTCOE (5,16)
8026 * | | | Compute the total cross section:
8027 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8029 * | | | Compute the elastic cross section:
8031 * | | | Compute the inelastic cross section:
8032 SHNCIN = SHNCTT - SHNCEL
8036 * | | +-------------------------------------------------------------*
8037 * | | Now compute the chain end (anti)quark-(anti)diquark
8038 * | | there are different possibilities, make a random choiche:
8040 RNCHEN = DT_RNDM(PUUBAR)
8041 IF ( RNCHEN .LT. PUUBAR ) THEN
8046 IQBSC1 = -IQFSC1 + KHELP
8049 * | +----------------------------------------------------------------*
8053 * | | +-------------------------------------------------------------*
8054 * | | | Proton target: (nbar p)in supposed to be given by
8055 * | | | (pbar p)in - Sig_diagr
8056 IF ( KHELP .EQ. 0 ) THEN
8057 SHNCIN = SAPPIN - SIGDIA
8060 * | | +-------------------------------------------------------------*
8061 * | | | Neutron target: (nbar n)el is supposed to be equal to
8062 * | | | (pbar p)el (reasonable above 5 GeV/c)
8064 * | | | Compute the total cross section:
8066 * | | | Compute the elastic cross section:
8068 * | | | Compute the inelastic cross section:
8069 SHNCIN = SHNCTT - SHNCEL
8073 * | | +-------------------------------------------------------------*
8074 * | | Now compute the chain end (anti)quark-(anti)diquark
8075 * | | there are different possibilities, make a random choiche:
8077 RNCHEN = DT_RNDM(RNCHEN)
8078 IF ( RNCHEN .LT. PDDBAR ) THEN
8083 IQBSC1 = -IQFSC1 + KHELP - 1
8087 * | +----------------------------------------------------------------*
8089 * +-------------------------------------------------------------------*
8090 * | Others: not yet implemented
8099 * +-------------------------------------------------------------------*
8100 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8101 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8103 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8107 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8109 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8110 & + IQSCHR (MQUARK(3,IP))
8111 * +-------------------------------------------------------------------*
8112 * | Consistency check:
8113 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8114 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8115 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8116 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8117 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8118 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8119 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8122 * +-------------------------------------------------------------------*
8123 * +-------------------------------------------------------------------*
8124 * | Consistency check:
8125 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8126 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8128 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8129 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8131 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8132 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8135 * +-------------------------------------------------------------------*
8136 * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8137 IF ( UMORAT .GT. ONEPLS )
8138 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8139 & - ONEONE ) * UMORAT + ONEONE )
8142 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8148 *=== End of function Phnsch ===========================================*
8152 *===respt==============================================================*
8157 ************************************************************************
8158 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8159 * This version dated 18.01.95 is written by S. Roesler *
8160 ************************************************************************
8162 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8165 PARAMETER ( LINP = 5 ,
8169 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8173 PARAMETER (NMXHKK=200000)
8175 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8176 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8177 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8178 * extended event history
8179 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8180 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8183 * get index of first chain
8184 DO 1 I=NPOINT(3),NHKK
8185 IF (IDHKK(I).EQ.88888) THEN
8192 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8193 C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8194 * skip VV-,SS- systems
8195 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8196 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8197 * check if both "chains" are resonances
8198 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8199 CALL DT_SAPTRE(NC,NC+3)
8213 *===evtres=============================================================*
8215 CDECK ID>, DT_EVTRES
8216 SUBROUTINE DT_EVTRES(IREJ)
8218 ************************************************************************
8219 * This version dated 14.12.94 is written by S. Roesler *
8220 ************************************************************************
8222 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8225 PARAMETER ( LINP = 5 ,
8229 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8233 PARAMETER (NMXHKK=200000)
8235 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8236 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8237 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8238 * extended event history
8239 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8240 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8242 * flags for input different options
8243 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8244 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8245 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8246 * particle properties (BAMJET index convention)
8248 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8249 & IICH(210),IIBAR(210),K1(210),K2(210)
8251 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8255 DO 1 I=NPOINT(3),NHKK
8256 IF (ABS(IDRES(I)).GE.100) THEN
8258 DO 2 J=NPOINT(3),NHKK
8259 IF (IDHKK(J).EQ.88888) THEN
8260 IF (PHKK(5,J).GT.AMMX) THEN
8266 IF (IDRES(IMMX).NE.0) THEN
8267 IF (IOULEV(3).GT.0) THEN
8268 WRITE(LOUT,'(1X,A)')
8269 & 'EVTRES: no chain for correc. found'
8278 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8282 IMO21 = JMOHKK(1,IMMX)
8283 IMO22 = JMOHKK(2,IMMX)
8284 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8285 IMO21 = JMOHKK(2,IMMX)
8286 IMO22 = JMOHKK(1,IMMX)
8289 AMCH1N = AAM(IDXRES(I))
8291 IFPR1 = IDHKK(IMO11)
8292 IFPR2 = IDHKK(IMO21)
8293 IFTA1 = IDHKK(IMO12)
8294 IFTA2 = IDHKK(IMO22)
8296 PP1(J) = PHKK(J,IMO11)
8297 PP2(J) = PHKK(J,IMO21)
8298 PT1(J) = PHKK(J,IMO12)
8299 PT2(J) = PHKK(J,IMO22)
8301 * store initial configuration for energy-momentum cons. check
8302 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8303 * correct kinematics of second chain
8304 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8305 & AMCH1,AMCH1N,AMCH2,IREJ1)
8306 IF (IREJ1.NE.0) GOTO 9999
8307 * check now this chain for resonance mass
8308 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8310 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8311 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8313 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8315 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8316 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8317 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8318 & AMCH2,AMCH2N,IDCH2,IREJ1)
8319 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8321 & WRITE(LOUT,*) ' correction for resonance not poss.'
8327 * store final configuration for energy-momentum cons. check
8329 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8330 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8331 IF (IREJ1.NE.0) GOTO 9999
8334 PHKK(J,IMO11) = PP1(J)
8335 PHKK(J,IMO21) = PP2(J)
8336 PHKK(J,IMO12) = PT1(J)
8337 PHKK(J,IMO22) = PT2(J)
8339 * correct entries of chains
8341 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8342 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8344 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8345 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8347 * ?? the following should now be obsolete
8349 C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8350 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8352 WRITE(LOUT,'(1X,A,4G10.3)')
8353 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8357 PHKK(5,I) = SQRT(AM1)
8358 PHKK(5,IMMX) = SQRT(AM2)
8359 IDRES(I) = IDRES(I)/100
8360 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8361 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8362 WRITE(LOUT,'(1X,A,4G10.3)')
8363 & 'EVTRES: inconsistent chain-masses',
8364 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8377 *===getspt=============================================================*
8379 CDECK ID>, DT_GETSPT
8380 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8381 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8382 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8384 ************************************************************************
8385 * This version dated 12.12.94 is written by S. Roesler *
8386 ************************************************************************
8388 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8391 PARAMETER ( LINP = 5 ,
8395 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8397 * various options for treatment of partons (DTUNUC 1.x)
8398 * (chain recombination, Cronin,..)
8399 LOGICAL LCO2CR,LINTPT
8400 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8402 * flags for input different options
8403 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8404 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8405 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8406 * flags for diffractive interactions (DTUNUC 1.x)
8407 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8409 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8410 & PT2(4),PT2I(4),P1(4),P2(4),
8411 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8412 & PTOTI(4),PTOTF(4),DIFF(4)
8418 C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8419 C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8425 IF (IDIFF.NE.0) THEN
8431 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8437 * get initial chain masses
8438 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8439 & +(PP1(3)+PT1(3))**2)
8441 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8442 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8443 & +(PP2(3)+PT2(3))**2)
8445 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8446 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8448 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8458 C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8462 C IF (AM1.LT.0.6) THEN
8464 C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8467 C IF (AM2.LT.0.6) THEN
8469 C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8474 * check chain masses for very low mass chains
8475 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8476 C & AM1,DUM,-IDCH1,IREJ1)
8477 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8478 C & AM2,DUM,-IDCH2,IREJ2)
8479 C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8488 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8489 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8490 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8491 C IF (MOD(IC,19).EQ.0) JMSHL = 0
8492 IF (MOD(IC,20).EQ.0) GOTO 7
8493 C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8498 * get transverse momentum
8500 ES = -2.0D0/(B33P**2)
8501 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8502 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8504 ES = -2.0D0/(B33T**2)
8505 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8506 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8512 CALL DT_DSFECF(SFE1,CFE1)
8513 CALL DT_DSFECF(SFE2,CFE2)
8515 PP1(1) = PP1I(1)+HPSP*CFE1
8516 PP1(2) = PP1I(2)+HPSP*SFE1
8517 PP2(1) = PP2I(1)-HPSP*CFE1
8518 PP2(2) = PP2I(2)-HPSP*SFE1
8519 PT1(1) = PT1I(1)+HPST*CFE2
8520 PT1(2) = PT1I(2)+HPST*SFE2
8521 PT2(1) = PT2I(1)-HPST*CFE2
8522 PT2(2) = PT2I(2)-HPST*SFE2
8524 PP1(1) = PP1I(1)+HPSP*CFE1
8525 PP1(2) = PP1I(2)+HPSP*SFE1
8526 PT1(1) = PT1I(1)-HPSP*CFE1
8527 PT1(2) = PT1I(2)-HPSP*SFE1
8528 PP2(1) = PP2I(1)+HPST*CFE2
8529 PP2(2) = PP2I(2)+HPST*SFE2
8530 PT2(1) = PT2I(1)-HPST*CFE2
8531 PT2(2) = PT2I(2)-HPST*SFE2
8534 * put partons on mass shell
8537 IF (JMSHL.EQ.1) THEN
8539 XMP1 = PYMASS(IFPR1)
8540 XMT1 = PYMASS(IFTA1)
8543 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8544 IF (IREJ1.NE.0) GOTO 2
8546 PTOTF(I) = P1(I)+P2(I)
8552 IF (JMSHL.EQ.1) THEN
8554 XMP2 = PYMASS(IFPR2)
8555 XMT2 = PYMASS(IFTA2)
8558 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8559 IF (IREJ1.NE.0) GOTO 2
8561 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8568 DIFF(I) = PTOTI(I)-PTOTF(I)
8570 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8571 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8572 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8575 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8576 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8577 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8578 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8579 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8580 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8581 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8582 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8583 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8584 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8586 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8587 & 'GETSPT: inconsistent masses',
8588 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8589 * sr 22.11.00: commented. It should only have inconsistent masses for
8590 * ultrahigh energies due to rounding problems
8595 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8596 & +(PP1(3)+PT1(3))**2)
8598 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
8599 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8600 & +(PP2(3)+PT2(3))**2)
8602 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
8603 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8605 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8612 * check chain masses for very low mass chains
8613 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8614 & AM1N,DUM,-IDCH1,IREJ1)
8615 IF (IREJ1.NE.0) GOTO 2
8616 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8617 & AM2N,DUM,-IDCH2,IREJ2)
8618 IF (IREJ2.NE.0) GOTO 2
8621 IF (AM1N.GT.ZERO) THEN
8639 *===saptre=============================================================*
8641 CDECK ID>, DT_SAPTRE
8642 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8644 ************************************************************************
8645 * p-t sampling for two-resonance systems. ("BAMJET-like" method) *
8646 * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
8647 * Adopted from the original SAPTRE written by J. Ranft. *
8648 * This version dated 18.01.95 is written by S. Roesler *
8649 ************************************************************************
8651 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8654 PARAMETER ( LINP = 5 ,
8658 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8662 PARAMETER (NMXHKK=200000)
8664 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8665 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8666 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8667 * extended event history
8668 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8669 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8671 * flags for input different options
8672 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8673 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8674 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8676 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8680 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8681 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8682 ESMAX = MIN(ESMAX1,ESMAX2)
8683 IF (ESMAX.LE.0.05D0) RETURN
8687 PA1(K) = PHKK(K,IDX1)
8688 PA2(K) = PHKK(K,IDX2)
8692 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8693 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8697 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8698 BEXP = HMA*(1.0D0-EXEB)/B3
8699 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8700 WA = AXEXP/(BEXP+AXEXP)
8703 * ES is the transverse kinetic energy
8707 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8710 ES = ABS(-LOG(X+TINY7)/B3)
8712 IF (ES.GT.ESMAX) GOTO 10
8714 * transverse momentum
8715 HPS = SQRT((ES-HMA)*(ES+HMA))
8717 CALL DT_DSFECF(SFE,CFE)
8720 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8721 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8722 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8724 C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8725 C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8731 * put resonances on mass-shell again
8734 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8735 IF (IREJ1.NE.0) RETURN
8738 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8739 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8740 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8741 IF (IREJ1.NE.0) RETURN
8745 PHKK(K,IDX1) = P1(K)
8746 PHKK(K,IDX2) = P2(K)
8752 *===cronin=============================================================*
8754 CDECK ID>, DT_CRONIN
8755 SUBROUTINE DT_CRONIN(INCL)
8757 ************************************************************************
8758 * Cronin-Effect. Multiple scattering of partons at chain ends. *
8759 * INCL = 1 multiple sc. in projectile *
8760 * = 2 multiple sc. in target *
8761 * This version dated 05.01.96 is written by S. Roesler. *
8762 ************************************************************************
8764 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8767 PARAMETER ( LINP = 5 ,
8771 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8775 PARAMETER (NMXHKK=200000)
8777 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8778 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8779 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8780 * extended event history
8781 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8782 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8785 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8786 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8787 & IREXCI(3),IRDIFF(2),IRINC
8788 * Glauber formalism: collision properties
8789 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8790 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8792 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8798 DO 2 I=NPOINT(2),NHKK
8799 IF (ISTHKK(I).LT.0) THEN
8800 * get z-position of the chain
8801 R(1) = VHKK(1,I)*1.0D12
8802 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8803 R(2) = VHKK(2,I)*1.0D12
8805 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8806 & IDXNU = JMOHKK(1,I-1)
8807 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8808 & IDXNU = JMOHKK(1,I+1)
8809 R(3) = VHKK(3,IDXNU)*1.0D12
8810 * position of target parton the chain is connected to
8814 * multiple scattering of parton with DTEVT1-index I
8815 CALL DT_CROMSC(PIN,R,POUT,INCL)
8817 C IF (NEVHKK.EQ.5) THEN
8818 C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8819 C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8820 C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8821 C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8822 C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8823 C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
8824 C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
8827 * increase accumulator by energy-momentum difference
8829 DEV(K) = DEV(K)+POUT(K)-PIN(K)
8832 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8833 & PHKK(2,I)**2-PHKK(3,I)**2))
8837 * dump accumulator to momenta of valence partons
8840 DO 5 I=NPOINT(2),NHKK
8841 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8843 ETOT = ETOT+PHKK(4,I)
8846 C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8847 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
8849 DO 6 I=NPOINT(2),NHKK
8850 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8853 C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8854 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8856 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8857 & PHKK(2,I)**2-PHKK(3,I)**2))
8864 *===cromsc=============================================================*
8866 CDECK ID>, DT_CROMSC
8867 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8869 ************************************************************************
8870 * Cronin-Effect. Multiple scattering of one parton passing through *
8872 * PIN(4) input 4-momentum of parton *
8873 * POUT(4) 4-momentum of parton after mult. scatt. *
8874 * R(3) spatial position of parton in target nucleus *
8875 * INCL = 1 multiple sc. in projectile *
8876 * = 2 multiple sc. in target *
8877 * This is a revised version of the original version written by J. Ranft*
8878 * This version dated 17.01.95 is written by S. Roesler. *
8879 ************************************************************************
8881 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8884 PARAMETER ( LINP = 5 ,
8888 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8893 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8894 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8895 & IREXCI(3),IRDIFF(2),IRINC
8896 * Glauber formalism: collision properties
8897 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8898 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8899 * various options for treatment of partons (DTUNUC 1.x)
8900 * (chain recombination, Cronin,..)
8901 LOGICAL LCO2CR,LINTPT
8902 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8905 DIMENSION PIN(4),POUT(4),R(3)
8907 DATA LSTART /.TRUE./
8909 IRCRON(1) = IRCRON(1)+1
8912 WRITE(LOUT,1000) CRONCO
8913 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
8914 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8920 IF (INCL.EQ.2) RNCL = RTARG
8922 * Lorentz-transformation into Lab.
8924 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8926 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8927 IF (PTOT.LE.8.0D0) GOTO 9997
8929 * direction cosines of parton before mult. scattering
8934 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8935 IF (RTESQ.GE.-TINY3) GOTO 9999
8937 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8938 * in the direction of particle motion
8940 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8942 IF (TMP.LT.ZERO) GOTO 9998
8945 * multiple scattering angle
8946 THETO = CRONCO*SQRT(DIST)/PTOT
8947 IF (THETO.GT.0.1D0) THETO=0.1D0
8950 * Gaussian sampling of spatial angle
8951 CALL DT_RANNOR(R1,R2)
8952 THETA = ABS(R1*THETO)
8953 IF (THETA.GT.0.3D0) GOTO 9997
8954 CALL DT_DSFECF(SFE,CFE)
8958 * new direction cosines
8959 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8960 & COSXN,COSYN,COSZN)
8962 POUT(1) = COSXN*PTOT
8963 POUT(2) = COSYN*PTOT
8965 * Lorentz-transformation into nucl.-nucl. cms
8967 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8969 C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8970 C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8971 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8974 IF (MOD(NCBACK,200).EQ.0) THEN
8975 WRITE(LOUT,1001) THETO,PIN,POUT
8976 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8977 & E12.4,/,1X,' PIN :',4E12.4,/,
8978 & 1X,' POUT:',4E12.4)
8986 9997 IRCRON(2) = IRCRON(2)+1
8988 9998 IRCRON(3) = IRCRON(3)+1
8997 *===com2sr=============================================================*
8999 CDECK ID>, DT_COM2CR
9000 SUBROUTINE DT_COM2CR
9002 ************************************************************************
9003 * COMbine q-aq chains to Color Ropes (qq-aqaq). *
9004 * CUTOF parameter determining minimum number of not *
9005 * combined q-aq chains *
9006 * This subroutine replaces KKEVCC etc. *
9007 * This version dated 11.01.95 is written by S. Roesler. *
9008 ************************************************************************
9010 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9013 PARAMETER ( LINP = 5 ,
9019 PARAMETER (NMXHKK=200000)
9021 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9022 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9023 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9024 * extended event history
9025 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9026 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9029 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9030 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9032 * various options for treatment of partons (DTUNUC 1.x)
9033 * (chain recombination, Cronin,..)
9034 LOGICAL LCO2CR,LINTPT
9035 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9038 DIMENSION IDXQA(248),IDXAQ(248)
9040 ICCHAI(1,9) = ICCHAI(1,9)+1
9043 * scan DTEVT1 for q-aq, aq-q chains
9044 DO 10 I=NPOINT(3),NHKK
9045 * skip "chains" which are resonances
9046 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9049 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9050 * q-aq, aq-q chain found, keep index
9051 IF (IDHKK(MO1).GT.0) THEN
9062 * minimum number of q-aq chains requested for the same projectile/
9064 NCHMIN = IDT_NPOISS(CUTOF)
9066 * combine q-aq chains of the same projectile
9067 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9068 * combine q-aq chains of the same target
9069 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9070 * combine aq-q chains of the same projectile
9071 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9072 * combine aq-q chains of the same target
9073 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9078 *===scn4cr=============================================================*
9080 CDECK ID>, DT_SCN4CR
9081 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9083 ************************************************************************
9084 * SCan q-aq chains for Color Ropes. *
9085 * This version dated 11.01.95 is written by S. Roesler. *
9086 ************************************************************************
9088 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9091 PARAMETER ( LINP = 5 ,
9097 PARAMETER (NMXHKK=200000)
9099 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9100 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9101 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9102 * extended event history
9103 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9104 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9107 DIMENSION IDXCH(248),IDXJN(248)
9110 IF (IDXCH(I).GT.0) THEN
9112 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9116 IF (IDXCH(J).GT.0) THEN
9117 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9118 IF (IDXMO.EQ.IDXMO1) THEN
9125 IF (NJOIN.GE.NCHMIN+2) THEN
9126 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9128 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9129 IF (IREJ1.NE.0) GOTO 3
9131 IDXCH(IDXJN(J+1)) = 0
9140 *===join===============================================================*
9143 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9145 ************************************************************************
9146 * This subroutine joins two q-aq chains to one qq-aqaq chain. *
9147 * IDX1, IDX2 DTEVT1 indices of chains to be joined *
9148 * This version dated 11.01.95 is written by S. Roesler. *
9149 ************************************************************************
9151 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9154 PARAMETER ( LINP = 5 ,
9160 PARAMETER (NMXHKK=200000)
9162 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9163 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9164 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9165 * extended event history
9166 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9167 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9169 * flags for input different options
9170 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9171 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9172 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9174 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9175 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9178 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9186 MO(I,J) = JMOHKK(J,IDX(I))
9187 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9192 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9193 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9194 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9195 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9196 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9198 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9199 & 2I5,' chain ',I4,':',2I5)
9204 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9205 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9207 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9208 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9209 IST1 = ISTHKK(MO(1,1))
9210 IST2 = ISTHKK(MO(1,2))
9212 * put partons again on mass shell
9215 IF (IMSHL.EQ.1) THEN
9221 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9222 IF (IREJ1.NE.0) GOTO 9999
9228 * store new partons in DTEVT1
9229 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9231 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9234 PCH(K) = PP(K)+PT(K)
9237 * check new chain for lower mass limit
9238 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9239 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9240 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9241 & AMCH,AMCHN,3,IREJ1)
9242 IF (IREJ1.NE.0) THEN
9248 ICCHAI(2,9) = ICCHAI(2,9)+1
9249 * store new chain in DTEVT1
9251 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9252 IDHKK(IDX(1)) = 22222
9253 IDHKK(IDX(2)) = 22222
9254 * special treatment for space-time coordinates
9256 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9257 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9266 *===xsglau=============================================================*
9268 CDECK ID>, DT_XSGLAU
9269 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9271 ************************************************************************
9272 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9273 * Glauber's approach. *
9274 * NA / NB mass numbers of proj./target nuclei *
9275 * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9276 * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9277 * IE,IQ indices of energy and virtuality (the latter for gamma *
9278 * projectiles only) *
9279 * NIDX index of projectile/target nucleus *
9280 * This version dated 17.3.98 is written by S. Roesler *
9281 ************************************************************************
9283 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9286 PARAMETER ( LINP = 5 ,
9290 COMPLEX*16 CZERO,CONE,CTWO
9292 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9293 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9294 PARAMETER (TWOPI = 6.283185307179586454D+00,
9296 & GEV2MB = 0.38938D0,
9297 & GEV2FM = 0.1972D0,
9298 & ALPHEM = ONE/137.0D0,
9302 * approx. nucleon radius
9305 * particle properties (BAMJET index convention)
9307 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9308 & IICH(210),IIBAR(210),K1(210),K2(210)
9310 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9312 PARAMETER ( MAXNCL = 260,
9315 & MAXSQU = 20*MAXVQU,
9316 & MAXINT = MAXVQU+MAXSQU)
9317 * Glauber formalism: parameters
9318 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9319 & BMAX(NCOMPX),BSTEP(NCOMPX),
9320 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9322 * Glauber formalism: cross sections
9323 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9324 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9325 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9326 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9327 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9328 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9329 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9330 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9331 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9332 & BSLOPE,NEBINI,NQBINI
9333 * Glauber formalism: flags and parameters for statistics
9336 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9337 * nucleon-nucleon event-generator
9340 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9341 * VDM parameter for photon-nucleus interactions
9342 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9343 * parameters for hA-diffraction
9344 COMMON /DTDIHA/ DIBETA,DIALPH
9346 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9347 & OMPP11,OMPP12,OMPP21,OMPP22,
9348 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9351 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9352 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9355 PARAMETER (NPOINT=16)
9356 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9358 LOGICAL LFIRST,LOPEN
9359 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9362 * for quasi-elastic neutrino scattering set projectile to proton
9363 * it should not have an effect since the whole Glauber-formalism is
9364 * not needed for these interactions..
9365 IF (MCGENE.EQ.4) THEN
9371 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9374 CFILE = CGLB//'.glb'
9375 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9376 ELSEIF (I.GT.1) THEN
9377 CFILE = CGLB(1:I-1)//'.glb'
9378 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9385 CZERO = DCMPLX(ZERO,ZERO)
9386 CONE = DCMPLX(ONE,ZERO)
9387 CTWO = DCMPLX(TWO,ZERO)
9391 * re-define kinematics
9395 * g(Q2=0)-A, h-A, A-A scattering
9396 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9399 * g(Q2>0)-A scattering
9400 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9402 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9403 Q2 = (S-AMP2)*X/(ONE-X)
9404 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9405 S = Q2*(ONE-X)/X+AMP2
9407 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9412 XNU = (S+Q2-AMP2)/(TWO*AMP)
9414 * parameters determining statistics in evaluating Glauber-xsection
9417 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9419 * set up interaction geometry (common /DTGLAM/)
9420 * projectile/target radii
9421 RPRNCL = DT_RNCLUS(NA)
9422 RTANCL = DT_RNCLUS(NB)
9423 IF (IJPROJ.EQ.7) THEN
9425 RBSH(NTARG) = RTANCL
9426 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9428 IF (NIDX.LE.-1) THEN
9430 RBSH(NTARG) = RTANCL
9431 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9433 RASH(NTARG) = RPRNCL
9435 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9438 * maximum impact-parameter
9439 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9441 * slope, rho ( Re(f(0))/Im(f(0)) )
9442 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9443 IF (MCGENE.EQ.2) THEN
9445 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9448 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9450 IF (ECMNN(IE).LE.3.0D0) THEN
9452 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9453 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9454 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9457 ELSEIF (IJPROJ.EQ.7) THEN
9460 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9464 * projectile-nucleon xsection (in fm)
9465 IF (IJPROJ.EQ.7) THEN
9466 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9468 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9469 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9470 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9472 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9473 SIGSH = SIGSH/10.0D0
9476 * parameters for projectile diffraction (hA scattering only)
9477 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9478 & .AND.(DIBETA.GE.ZERO)) THEN
9480 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9481 C DIBETA = SDIF1/STOT
9483 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9484 IF (DIBETA.LE.ZERO) THEN
9487 ALPGAM = DIALPH/DIGAMM
9491 FACDI = SQRT(FACDI1*FACDI2)
9492 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9504 BSITE( 0,IQ,NTARG,I) = ZERO
9505 BSITE(IE,IQ,NTARG,I) = ZERO
9524 FACN = ONE/DBLE(NSTATB)
9529 * initialize Gauss-integration for photon-proj.
9531 IF (IJPROJ.EQ.7) THEN
9532 IF (INTRGE(1).EQ.1) THEN
9533 AMLO2 = (3.0D0*AAM(13))**2
9534 ELSEIF (INTRGE(1).EQ.2) THEN
9539 IF (INTRGE(2).EQ.1) THEN
9541 ELSEIF (INTRGE(2).EQ.2) THEN
9546 AMHI20 = (ECMNN(IE)-AMP)**2
9547 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9548 XAMLO = LOG( AMLO2+Q2 )
9549 XAMHI = LOG( AMHI2+Q2 )
9551 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9554 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9558 * ratio direct/total photon-nucleon xsection
9559 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9562 * read pre-initialized profile-function from file
9563 IF (IOGLB.EQ.1) THEN
9564 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9565 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9566 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9567 & NA,NB,NSTATB,NSITEB
9568 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9569 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9570 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
9573 IF (LFIRST) WRITE(LOUT,1001) CFILE
9574 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9576 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9577 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9578 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9579 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9580 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9581 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9582 NLINES = INT(DBLE(NSITEB)/7.0D0)
9583 IF (NLINES.GT.0) THEN
9586 READ(LDAT,'(7E11.4)')
9587 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9591 IF (ISTART.LE.NSITEB) THEN
9592 READ(LDAT,'(7E11.4)')
9593 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9597 * variable projectile/target/energy runs:
9598 * read pre-initialized profile-functions from file
9599 ELSEIF (IOGLB.EQ.100) THEN
9600 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9604 * cross sections averaged over NSTATB nucleon configurations
9606 C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9616 IF (NIDX.LE.-1) THEN
9617 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9618 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9619 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9620 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9621 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9624 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9625 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9626 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9627 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9628 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9632 * integration over impact parameter B
9643 B = DBLE(IB)*BSTEP(NTARG)
9644 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
9646 * integration over M_V^2 for photon-proj.
9652 IF (IJPROJ.EQ.7) THEN
9664 IF (IJPROJ.EQ.7) THEN
9665 AMV2 = EXP(ABSZX(IM))-Q2
9667 IF (AMV2.LT.16.0D0) THEN
9669 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9674 * define M_V dependent properties of nucleon scattering amplitude
9675 * V_M-nucleon xsection
9676 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9677 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9678 * slope-parametrisation a la Kaidalov
9679 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9680 & +0.25D0*LOG(S/(AMV2+Q2)))
9682 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9683 * integration weight factor
9684 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9685 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9687 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9689 IF (IJPROJ.EQ.7) THEN
9690 RCA = GAM*SIGMV/TWOPI
9692 RCA = GAM*SIGSH/TWOPI
9695 CA = DCMPLX(RCA,FCA)
9704 * photon-projectile: check for supression by coherence length
9705 IF (IJPROJ.EQ.7) THEN
9706 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9710 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9716 X11 = B+COOT1(1,INB)-COOP1(1,INA)
9717 Y11 = COOT1(2,INB)-COOP1(2,INA)
9718 XY11 = GAM*(X11*X11+Y11*Y11)
9719 IF (XY11.LE.15.0D0) THEN
9720 C = CONE-CA*EXP(-XY11)
9721 AR = DBLE(PP11(INT1))
9722 AI = DIMAG(PP11(INT1))
9723 IF (ABS(AR).LT.TINY25) AR = ZERO
9724 IF (ABS(AI).LT.TINY25) AI = ZERO
9725 PP11(INT1) = DCMPLX(AR,AI)
9726 PP11(INT1) = PP11(INT1)*C
9729 SHI = SHI+LOG(AR*AR+AI*AI)
9731 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9732 X12 = B+COOT2(1,INB)-COOP1(1,INA)
9733 Y12 = COOT2(2,INB)-COOP1(2,INA)
9734 XY12 = GAM*(X12*X12+Y12*Y12)
9735 IF (XY12.LE.15.0D0) THEN
9736 C = CONE-CA*EXP(-XY12)
9737 AR = DBLE(PP12(INT2))
9738 AI = DIMAG(PP12(INT2))
9739 IF (ABS(AR).LT.TINY25) AR = ZERO
9740 IF (ABS(AI).LT.TINY25) AI = ZERO
9741 PP12(INT2) = DCMPLX(AR,AI)
9742 PP12(INT2) = PP12(INT2)*C
9744 X21 = B+COOT1(1,INB)-COOP2(1,INA)
9745 Y21 = COOT1(2,INB)-COOP2(2,INA)
9746 XY21 = GAM*(X21*X21+Y21*Y21)
9747 IF (XY21.LE.15.0D0) THEN
9748 C = CONE-CA*EXP(-XY21)
9749 AR = DBLE(PP21(INT1))
9750 AI = DIMAG(PP21(INT1))
9751 IF (ABS(AR).LT.TINY25) AR = ZERO
9752 IF (ABS(AI).LT.TINY25) AI = ZERO
9753 PP21(INT1) = DCMPLX(AR,AI)
9754 PP21(INT1) = PP21(INT1)*C
9756 X22 = B+COOT2(1,INB)-COOP2(1,INA)
9757 Y22 = COOT2(2,INB)-COOP2(2,INA)
9758 XY22 = GAM*(X22*X22+Y22*Y22)
9759 IF (XY22.LE.15.0D0) THEN
9760 C = CONE-CA*EXP(-XY22)
9761 AR = DBLE(PP22(INT2))
9762 AI = DIMAG(PP22(INT2))
9763 IF (ABS(AR).LT.TINY25) AR = ZERO
9764 IF (ABS(AI).LT.TINY25) AI = ZERO
9765 PP22(INT2) = DCMPLX(AR,AI)
9766 PP22(INT2) = PP22(INT2)*C
9777 IF (PP11(K).EQ.CZERO) THEN
9781 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9782 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9785 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9786 OMPP11 = OMPP11+AVDIPP
9787 C OMPP11 = OMPP11+(CONE-PP11(K))
9788 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9789 DIPP11 = DIPP11+AVDIPP
9790 IF (PP21(K).EQ.CZERO) THEN
9794 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9795 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9798 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9799 OMPP21 = OMPP21+AVDIPP
9800 C OMPP21 = OMPP21+(CONE-PP21(K))
9801 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9802 DIPP21 = DIPP21+AVDIPP
9809 IF (PP12(K).EQ.CZERO) THEN
9813 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9814 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9817 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9818 OMPP12 = OMPP12+AVDIPP
9819 C OMPP12 = OMPP12+(CONE-PP12(K))
9820 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9821 DIPP12 = DIPP12+AVDIPP
9822 IF (PP22(K).EQ.CZERO) THEN
9826 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9827 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9830 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9831 OMPP22 = OMPP22+AVDIPP
9832 C OMPP22 = OMPP22+(CONE-PP22(K))
9833 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9834 DIPP22 = DIPP22+AVDIPP
9837 SPROM = ONE-EXP(SHI)
9838 SPROB = SPROB+FACM*SPROM
9839 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9840 STOTM = DBLE(OMPP11+OMPP22)
9841 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9842 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9843 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9844 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9845 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9846 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9847 STOTB = STOTB+FACM*STOTM
9848 SELAB = SELAB+FACM*SELAM
9849 SDELB = SDELB+FACM*SDELM
9851 SQEPB = SQEPB+FACM*SQEPM
9852 SDQEB = SDQEB+FACM*SDQEM
9854 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9855 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9856 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9861 STOTN = STOTN+FACB*STOTB
9862 SELAN = SELAN+FACB*SELAB
9863 SQEPN = SQEPN+FACB*SQEPB
9864 SQETN = SQETN+FACB*SQETB
9865 SQE2N = SQE2N+FACB*SQE2B
9866 SPRON = SPRON+FACB*SPROB
9867 SDELN = SDELN+FACB*SDELB
9868 SDQEN = SDQEN+FACB*SDQEB
9870 IF (IJPROJ.EQ.7) THEN
9871 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9873 IF (DIBETA.GT.ZERO) THEN
9874 BPROD(IB+1)= BPROD(IB+1)
9875 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9877 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9883 STOT = STOT +FACN*STOTN
9884 STOT2 = STOT2+FACN*STOTN**2
9885 SELA = SELA +FACN*SELAN
9886 SELA2 = SELA2+FACN*SELAN**2
9887 SQEP = SQEP +FACN*SQEPN
9888 SQEP2 = SQEP2+FACN*SQEPN**2
9889 SQET = SQET +FACN*SQETN
9890 SQET2 = SQET2+FACN*SQETN**2
9891 SQE2 = SQE2 +FACN*SQE2N
9892 SQE22 = SQE22+FACN*SQE2N**2
9893 SPRO = SPRO +FACN*SPRON
9894 SPRO2 = SPRO2+FACN*SPRON**2
9895 SDEL = SDEL +FACN*SDELN
9896 SDEL2 = SDEL2+FACN*SDELN**2
9897 SDQE = SDQE +FACN*SDQEN
9898 SDQE2 = SDQE2+FACN*SDQEN**2
9902 * final cross sections
9904 XSTOT(IE,IQ,NTARG) = STOT
9906 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9908 XSELA(IE,IQ,NTARG) = SELA
9909 * 3) quasi-el.: A+B-->A+X (excluding 2)
9910 XSQEP(IE,IQ,NTARG) = SQEP
9911 * 4) quasi-el.: A+B-->X+B (excluding 2)
9912 XSQET(IE,IQ,NTARG) = SQET
9913 * 5) quasi-el.: A+B-->X (excluding 2-4)
9914 XSQE2(IE,IQ,NTARG) = SQE2
9915 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9916 IF (SDEL.GT.ZERO) THEN
9917 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9919 XSPRO(IE,IQ,NTARG) = SPRO
9921 * 7) projectile diffraction (el. scatt. off target)
9922 XSDEL(IE,IQ,NTARG) = SDEL
9923 * 8) projectile diffraction (quasi-el. scatt. off target)
9924 XSDQE(IE,IQ,NTARG) = SDQE
9926 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9927 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9928 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9929 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9930 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9931 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9932 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9933 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9935 IF (IJPROJ.EQ.7) THEN
9936 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9937 & -XSQEP(IE,IQ,NTARG)
9939 BNORM = XSPRO(IE,IQ,NTARG)
9942 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9943 IF ((IE.EQ.1).AND.(IQ.EQ.1))
9944 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9947 * write profile function data into file
9948 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9949 WRITE(LDAT,'(5I10,1P,E15.5)')
9950 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9951 WRITE(LDAT,'(1P,6E12.5)')
9952 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9953 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9954 WRITE(LDAT,'(1P,6E12.5)')
9955 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9956 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9957 NLINES = INT(DBLE(NSITEB)/7.0D0)
9958 IF (NLINES.GT.0) THEN
9961 WRITE(LDAT,'(1P,7E11.4)')
9962 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9966 IF (ISTART.LE.NSITEB) THEN
9967 WRITE(LDAT,'(1P,7E11.4)')
9968 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9974 C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9979 *===getbxs=============================================================*
9981 CDECK ID>, DT_GETBXS
9982 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9984 ************************************************************************
9985 * Biasing in impact parameter space. *
9986 * XSFRAC = 0 : BLO - minimum impact parameter (input) *
9987 * BHI - maximum impact parameter (input) *
9988 * XSFRAC - fraction of cross section corresponding *
9989 * to impact parameter range (BLO,BHI) *
9991 * XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
9992 * BHI - maximum impact parameter giving requested *
9993 * fraction of cross section in impact *
9994 * parameter range (0,BMAX) (output) *
9995 * This version dated 17.03.00 is written by S. Roesler *
9996 ************************************************************************
9998 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10001 PARAMETER ( LINP = 5 ,
10005 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10007 * Glauber formalism: parameters
10008 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10009 & BMAX(NCOMPX),BSTEP(NCOMPX),
10010 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10014 IF (XSFRAC.LE.0.0D0) THEN
10015 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10016 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10017 IF (ILO.GE.IHI) THEN
10021 IF (ILO.EQ.NSITEB-1) THEN
10022 FRCLO = BSITE(0,1,NTARG,NSITEB)
10024 FRCLO = BSITE(0,1,NTARG,ILO+1)
10025 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10026 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10028 IF (IHI.EQ.NSITEB-1) THEN
10029 FRCHI = BSITE(0,1,NTARG,NSITEB)
10031 FRCHI = BSITE(0,1,NTARG,IHI+1)
10032 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10033 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10035 XSFRAC = FRCHI-FRCLO
10040 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10041 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
10042 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10043 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10053 *===conucl=============================================================*
10055 CDECK ID>, DT_CONUCL
10056 SUBROUTINE DT_CONUCL(X,N,R,MODE)
10058 ************************************************************************
10059 * Calculation of coordinates of nucleons within nuclei. *
10060 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
10061 * N / R number of nucleons / radius of nucleus (input) *
10062 * MODE = 0 coordinates not sorted *
10063 * = 1 coordinates sorted with increasing X(3,i) *
10064 * = 2 coordinates sorted with decreasing X(3,i) *
10065 * This version dated 26.10.95 is revised by S. Roesler *
10066 ************************************************************************
10068 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10071 PARAMETER ( LINP = 5 ,
10075 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10076 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10078 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10080 PARAMETER (NSRT=10)
10081 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10082 DIMENSION X(3,N),XTMP(3,260)
10084 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10086 IF ((MODE.NE.0).AND.((N.EQ.3).OR.(N.GT.4))) THEN
10089 IF (MODE.EQ.2) THEN
10095 DO 2 J=1,ICSRT(ISRT)
10097 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10098 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10099 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10101 IF (ICSRT(ISRT).GT.1) THEN
10104 CALL DT_SORT(X,N,I0,I1,MODE)
10107 ELSEIF ((MODE.NE.0).AND.((N.EQ.2).OR.(N.EQ.4))) THEN
10113 CALL DT_SORT(X,N,1,N,MODE)
10125 *===coordi=============================================================*
10127 CDECK ID>, DT_COORDI
10128 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10130 ************************************************************************
10131 * Calculation of coordinates of nucleons within nuclei. *
10132 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
10133 * N / R number of nucleons / radius of nucleus (input) *
10134 * Based on the original version by Shmakov et al. *
10135 * This version dated 26.10.95 is revised by S. Roesler *
10136 ************************************************************************
10138 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10141 PARAMETER ( LINP = 5 ,
10145 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10146 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10148 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10152 PARAMETER (NSRT=10)
10153 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10154 DIMENSION X(3,260),WD(4),RD(3)
10156 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10157 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10158 DATA RD /2.09D0, 0.935D0, 0.697D0/
10168 ELSEIF (N.EQ.2) THEN
10169 EPS = DT_RNDM(RD(1))
10171 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10175 CALL DT_RANNOR(X1,X2)
10179 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10182 CALL DT_RANNOR(X3,X4)
10184 CALL DT_RANNOR(X1,X2)
10187 IF (LSTART) GOTO 80
10189 CALL DT_RANNOR(X3,X4)
10194 LSTART = .NOT.LSTART
10195 X1SUM = X1SUM+X(1,I)
10196 X2SUM = X2SUM+X(2,I)
10197 X3SUM = X3SUM+X(3,I)
10199 X1SUM = X1SUM/DBLE(N)
10200 X2SUM = X2SUM/DBLE(N)
10201 X3SUM = X3SUM/DBLE(N)
10203 X(1,I) = X(1,I)-X1SUM
10204 X(2,I) = X(2,I)-X2SUM
10205 X(3,I) = X(3,I)-X3SUM
10209 * maximum nuclear radius for coordinate sampling
10210 RMAX = R+4.605D0*PDIF
10212 * initialize pre-sorting
10216 DR = TWO*RMAX/DBLE(NSRT)
10218 * sample coordinates for N nucleons
10221 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10222 F = DT_DENSIT(N,RAD,R)
10223 IF (DT_RNDM(RAD).GT.F) GOTO 120
10224 * theta, phi uniformly distributed
10225 CT = ONE-TWO*DT_RNDM(F)
10226 ST = SQRT((ONE-CT)*(ONE+CT))
10227 CALL DT_DSFECF(SFE,CFE)
10228 X(1,I) = RAD*ST*CFE
10229 X(2,I) = RAD*ST*SFE
10231 * ensure that distance between two nucleons is greater than R2MIN
10232 IF (I.LT.2) GOTO 122
10235 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10236 & (X(3,I)-X(3,I2))**2
10237 IF (DIST2.LE.R2MIN) GOTO 120
10240 * save index according to z-bin
10241 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10242 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10243 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10244 X1SUM = X1SUM+X(1,I)
10245 X2SUM = X2SUM+X(2,I)
10246 X3SUM = X3SUM+X(3,I)
10248 X1SUM = X1SUM/DBLE(N)
10249 X2SUM = X2SUM/DBLE(N)
10250 X3SUM = X3SUM/DBLE(N)
10252 X(1,I) = X(1,I)-X1SUM
10253 X(2,I) = X(2,I)-X2SUM
10254 X(3,I) = X(3,I)-X3SUM
10262 *===densit=============================================================*
10264 CDECK ID>, DT_DENSIT
10265 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10267 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10270 PARAMETER ( LINP = 5 ,
10274 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10275 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10278 DIMENSION R0(18),FNORM(18)
10279 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10280 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10281 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10282 & 2.72D0, 2.66D0, 2.79D0/
10283 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10284 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10285 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10286 & .1214D+01,.1265D+01,.1318D+01/
10287 DATA PDIF /0.545D0/
10293 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10294 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10295 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10296 & *EXP(-(R/R1)**2)/FNORM(NA)
10298 ELSEIF (NA.GT.18) THEN
10299 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10305 *===rnclus=============================================================*
10307 CDECK ID>, DT_RNCLUS
10308 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10310 ************************************************************************
10311 * Nuclear radius for nucleus with mass number N. *
10312 * This version dated 26.9.00 is written by S. Roesler *
10313 ************************************************************************
10315 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10318 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10321 PARAMETER (RNUCLE = 1.12D0)
10323 * nuclear radii for selected nuclei
10324 DIMENSION RADNUC(18)
10325 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10326 & 2.58D0,2.71D0,2.66D0,2.71D0/
10329 IF (RADNUC(N).GT.0.0D0) THEN
10330 DT_RNCLUS = RADNUC(N)
10332 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10335 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10341 *===dentst=============================================================*
10343 C PROGRAM DT_DENTST
10344 CDECK ID>, DT_DENTST
10345 SUBROUTINE DT_DENTST
10347 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10350 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10351 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10356 DR = (RMAX-RMIN)/DBLE(NBINS)
10360 R = RMIN+DBLE(IR-1)*DR
10361 F = DT_DENSIT(IA,R,R)
10362 IF (F.GT.FMAX) FMAX = F
10363 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10365 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10373 *===shmaki=============================================================*
10375 CDECK ID>, DT_SHMAKI
10376 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10378 ************************************************************************
10379 * Initialisation of Glauber formalism. This subroutine has to be *
10380 * called once (in case of target emulsions as often as many different *
10381 * target nuclei are considered) before events are sampled. *
10382 * NA / NCA mass number/charge of projectile nucleus *
10383 * NB / NCB mass number/charge of target nucleus *
10384 * IJP identity of projectile (hadrons/leptons/photons) *
10385 * PPN projectile momentum (for projectile nuclei: *
10386 * momentum per nucleon) in target rest system *
10387 * MODE = 0 Glauber formalism invoked *
10388 * = 1 fitted results are loaded from data-file *
10389 * = 99 NTARG is forced to be 1 *
10390 * (used in connection with GLAUBERI-card only) *
10391 * This version dated 22.03.96 is based on the original SHMAKI-routine *
10392 * and revised by S. Roesler. *
10393 ************************************************************************
10395 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10398 PARAMETER ( LINP = 5 ,
10402 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10405 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10407 * Glauber formalism: parameters
10408 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10409 & BMAX(NCOMPX),BSTEP(NCOMPX),
10410 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10412 * Lorentz-parameters of the current interaction
10413 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10414 & UMO,PPCM,EPROJ,PPROJ
10415 * properties of photon/lepton projectiles
10416 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10417 * kinematical cuts for lepton-nucleus interactions
10418 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10419 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10420 * Glauber formalism: cross sections
10421 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10422 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10423 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10424 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10425 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10426 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10427 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10428 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10429 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10430 & BSLOPE,NEBINI,NQBINI
10431 * cuts for variable energy runs
10432 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10433 * nucleon-nucleon event-generator
10436 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10437 * Glauber formalism: flags and parameters for statistics
10440 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10442 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10448 IF (MODE.EQ.99) NTARG = 1
10450 IF (MODE.EQ.-1) NIDX = NTARG
10452 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10453 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10454 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10455 & ' initialization',/,12X,'--------------------------',
10456 & '-------------------------',/)
10458 IF (MODE.EQ.2) THEN
10459 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10460 CALL DT_SHFAST(MODE,PPN,IBACK)
10461 STOP ' Glauber pre-initialization done'
10463 IF (MODE.EQ.1) THEN
10464 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10467 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10468 IF (IBACK.EQ.1) THEN
10469 * lepton-nucleus (variable energy runs)
10470 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10471 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10472 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10473 & WRITE(LOUT,1002) NB,NCB
10474 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10475 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10476 & 'E_cm (GeV) Q^2 (GeV^2)',
10477 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10478 & '--------------------------------',
10479 & '------------------------------')
10480 AECMLO = LOG10(MIN(UMO,ECMLI))
10481 AECMHI = LOG10(MIN(UMO,ECMHI))
10483 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10484 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10486 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10487 IF (Q2HI.GT.0.1D0) THEN
10488 IF (Q2LI.LT.0.01D0) THEN
10489 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10490 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10492 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10499 AQ2LO = LOG10(Q2LI)
10500 AQ2HI = LOG10(Q2HI)
10501 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10502 DO 2 J=IBIN,IQSTEP+IBIN
10503 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10504 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10505 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10506 & WRITE(LOUT,1003) ECMNN(I),
10507 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10510 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10511 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10513 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10515 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10519 * hadron/photon/nucleus-nucleus
10520 IF ((ABS(VAREHI).GT.ZERO).AND.
10521 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10522 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10523 WRITE(LOUT,1004) NA,NB,NCB
10524 1004 FORMAT(1X,'variable energy run: projectile-id:',
10525 & I3,' target A/Z: ',I3,' /',I3,/)
10527 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10528 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10529 & ' -------------------------------------',
10530 & '--------------------------------------')
10532 AECMLO = LOG10(VARCLO)
10533 AECMHI = LOG10(VARCHI)
10535 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10536 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10538 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10543 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10544 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10545 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10546 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10548 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10549 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10553 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10559 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10560 & (IOGLB.NE.100)) THEN
10561 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10562 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10563 1001 FORMAT(38X,'projectile',
10564 & ' target',/,1X,'Mass number / charge',
10565 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10566 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10567 & 'Parameters of elastic scattering amplitude:',/,5X,
10568 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10569 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10570 & 'statistics at each b-step',4X,I5,/,/,1X,
10571 & 'Prod. cross section ',5X,F10.4,' mb',/)
10577 *===profbi=============================================================*
10579 CDECK ID>, DT_PROFBI
10580 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10582 ************************************************************************
10583 * Integral over profile function (to be used for impact-parameter *
10584 * sampling during event generation). *
10585 * Fitted results are used. *
10586 * NA / NB mass numbers of proj./target nuclei *
10587 * PPN projectile momentum (for projectile nuclei: *
10588 * momentum per nucleon) in target rest system *
10589 * NTARG index of target material (i.e. kind of nucleus) *
10590 * This version dated 31.05.95 is revised by S. Roesler *
10591 ************************************************************************
10593 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10596 PARAMETER ( LINP = 5 ,
10602 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10607 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10609 * Glauber formalism: parameters
10610 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10611 & BMAX(NCOMPX),BSTEP(NCOMPX),
10612 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10614 * Glauber formalism: cross sections
10615 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10616 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10617 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10618 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10619 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10620 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10621 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10622 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10623 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10624 & BSLOPE,NEBINI,NQBINI
10626 PARAMETER (NGLMAX=8000)
10627 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10628 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10630 DATA LSTART /.TRUE./
10633 * read fit-parameters from file
10634 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10637 READ(47,'(A80)') CNAME
10638 IF (CNAME.EQ.'STOP') GOTO 2
10640 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10641 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10642 & GLAFIT(4,I),GLAFIT(5,I)
10643 IF (I+1.GT.NGLMAX) THEN
10645 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
10646 & 'program stopped')
10663 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10664 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10667 IF (J.EQ.NGLPAR) IPOINT = J+1-K
10668 IF ((NNA.GT.NGLIP(IPOINT)).OR.
10669 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10670 IF (IPOINT.EQ.1) IPOINT = 0
10671 NATMP = NGLIP(IPOINT+1)
10672 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10678 C IF (J.EQ.NGLPAR) THEN
10682 DO 5 J1=J1BEG,J1END
10683 IF (NGLIP(J1).EQ.NATMP) THEN
10684 IF (PPN.LT.GLAPPN(J1)) THEN
10693 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10702 IF (IDXGLA.EQ.0) THEN
10703 WRITE(LOUT,1001) NNA,NNB,PPN
10704 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
10705 & 2I4,F6.0,') not found ')
10709 * no interpolation yet available
10710 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10712 BSITE(1,1,NTARG,1) = ZERO
10715 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10716 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10717 & GLAFIT(5,IDXGLA)*XX**4
10718 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10719 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10720 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10726 *===glaube=============================================================*
10728 CDECK ID>, DT_GLAUBE
10729 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10731 ************************************************************************
10732 * Calculation of configuartion of interacting nucleons for one event. *
10733 * NA / NB mass numbers of proj./target nuclei (input) *
10734 * B impact parameter (output) *
10735 * INTT total number of wounded nucleons " *
10736 * INTA / INTB number of wounded nucleons in proj. / target " *
10737 * JS / JT(i) number of collisions proj. / target nucleon i is *
10738 * involved (output) *
10739 * NIDX index of projectile/target material (input)*
10740 * This is an update of the original routine SHMAKO by J.Ranft/HJM *
10741 * This version dated 22.03.96 is revised by S. Roesler *
10742 ************************************************************************
10744 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10747 PARAMETER ( LINP = 5 ,
10751 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10752 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10754 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10756 PARAMETER ( MAXNCL = 260,
10759 & MAXSQU = 20*MAXVQU,
10760 & MAXINT = MAXVQU+MAXSQU)
10761 * Glauber formalism: parameters
10762 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10763 & BMAX(NCOMPX),BSTEP(NCOMPX),
10764 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10766 * Glauber formalism: cross sections
10767 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10768 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10769 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10770 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10771 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10772 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10773 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10774 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10775 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10776 & BSLOPE,NEBINI,NQBINI
10777 * Lorentz-parameters of the current interaction
10778 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10779 & UMO,PPCM,EPROJ,PPROJ
10780 * properties of photon/lepton projectiles
10781 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10782 * Glauber formalism: collision properties
10783 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10784 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10785 * Glauber formalism: flags and parameters for statistics
10788 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10790 DIMENSION JS(MAXNCL),JT(MAXNCL)
10794 * get actual energy from /DTLTRA/
10798 * new patch for pre-initialized variable projectile/target/energy runs
10799 IF (IOGLB.EQ.100) THEN
10800 CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10802 * variable energy run, interpolate profile function
10807 IF (NEBINI.GT.1) THEN
10808 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10812 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10814 IF (ECMNOW.LT.ECMNN(I)) THEN
10817 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10827 IF (NQBINI.GT.1) THEN
10828 IF (Q2.GE.Q2G(NQBINI)) THEN
10832 ELSEIF (Q2.GT.Q2G(1)) THEN
10834 IF (Q2.LT.Q2G(I)) THEN
10837 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
10838 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10839 C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10848 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10849 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10850 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10851 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10852 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10856 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10857 IF (NIDX.LE.-1) THEN
10859 RTARG = RBSH(NTARG)
10861 RPROJ = RASH(NTARG)
10868 *===diagr==============================================================*
10870 CDECK ID>, DT_DIAGR
10871 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10874 ************************************************************************
10875 * Based on the original version by Shmakov et al. *
10876 * This version dated 21.04.95 is revised by S. Roesler *
10877 ************************************************************************
10879 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10882 PARAMETER ( LINP = 5 ,
10886 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10887 PARAMETER (TWOPI = 6.283185307179586454D+00,
10889 & GEV2MB = 0.38938D0,
10890 & GEV2FM = 0.1972D0,
10891 & ALPHEM = ONE/137.0D0,
10900 PARAMETER ( MAXNCL = 260,
10903 & MAXSQU = 20*MAXVQU,
10904 & MAXINT = MAXVQU+MAXSQU)
10905 * particle properties (BAMJET index convention)
10907 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10908 & IICH(210),IIBAR(210),K1(210),K2(210)
10910 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10912 * emulsion treatment
10913 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10915 * Glauber formalism: parameters
10916 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10917 & BMAX(NCOMPX),BSTEP(NCOMPX),
10918 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10920 * Glauber formalism: cross sections
10921 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10922 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10923 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10924 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10925 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10926 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10927 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10928 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10929 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10930 & BSLOPE,NEBINI,NQBINI
10931 * VDM parameter for photon-nucleus interactions
10932 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10933 * nucleon-nucleon event-generator
10936 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10938 C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10940 C obsolete cut-off information
10941 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10942 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10944 * coordinates of nucleons
10945 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10946 * interface between Glauber formalism and DPM
10947 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10948 & INTER1(MAXINT),INTER2(MAXINT)
10949 * statistics: Glauber-formalism
10950 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10951 * n-n cross section fluctuations
10952 PARAMETER (NBINS = 1000)
10953 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10955 DIMENSION JS(MAXNCL),JT(MAXNCL),
10956 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10957 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10958 DIMENSION NWA(0:210),NWB(0:210)
10961 DATA LFIRST /.TRUE./
10963 DATA NTARGO,ICNT /0,0/
10969 IF (NCOMPO.EQ.0) THEN
10979 IF (NTARG.EQ.-1) THEN
10980 IF (NCOMPO.EQ.0) THEN
10981 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10982 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10983 & NCALL,NWAMAX,NWBMAX
10984 DO 18 I=1,MAX(NWAMAX,NWBMAX)
10985 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10986 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10987 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10997 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10999 X = SQ2/(S+SQ2-AMP2)
11000 XNU = (S+SQ2-AMP2)/(TWO*AMP)
11001 * photon projectiles: recalculate photon-nucleon amplitude
11002 IF (IJPROJ.EQ.7) THEN
11004 * VDM assumption: mass of V-meson
11005 AMV2 = DT_SAM2(SQ2,ECMNOW)
11007 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11008 * check for pointlike interaction
11009 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11011 C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11012 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11015 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11016 & +0.25D0*LOG(S/(AMV2+SQ2)))
11018 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11019 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11020 IF (MCGENE.EQ.2) THEN
11022 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11025 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11027 IF (ECMNOW.LE.3.0D0) THEN
11029 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11030 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11031 ELSEIF (ECMNOW.GT.50.0D0) THEN
11034 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11035 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11036 IF (MCGENE.EQ.2) THEN
11038 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11040 SIGSH = SIGSH/10.0D0
11042 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11044 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11045 SIGSH = SIGSH/10.0D0
11048 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11050 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11051 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11052 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11054 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11055 SIGSH = SIGSH/10.0D0
11057 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11059 RCA = GAM*SIGSH/TWOPI
11061 CA = DCMPLX(RCA,FCA)
11062 CI = DCMPLX(ONE,ZERO)
11066 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11079 IF (IJPROJ.EQ.7) THEN
11089 * nucleon configuration
11090 C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11091 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11092 C CALL DT_CONUCL(PKOO,NA,RASH,2)
11093 C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11094 IF (NIDX.LE.-1) THEN
11095 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11096 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11098 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11099 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11105 * LEPTO: pick out one struck nucleon
11106 IF (MCGENE.EQ.3) THEN
11109 IDX = INT(DT_RNDM(X)*NB)+1
11116 * cross section fluctuations
11118 IF (IFLUCT.EQ.1) THEN
11119 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11120 AFLUC = FLUIXX(IFLUK)
11125 * photon-projectile: check for supression by coherence length
11126 IF (IJPROJ.EQ.7) THEN
11127 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11132 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11133 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11134 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11135 IF (XY.LE.15.0D0) THEN
11136 C = CI-CA*AFLUC*EXP(-XY)
11140 IF (DT_RNDM(XY).GE.P) THEN
11142 IF (IJPROJ.EQ.7) THEN
11143 JNT0(KINT) = JNT0(KINT)+1
11144 IF (JNT0(KINT).GT.MAXNCL) THEN
11145 WRITE(LOUT,1001) MAXNCL
11147 & 'DIAGR: no. of requested interactions',
11148 & ' exceeds array dimensions ',I4)
11151 JS0(KINT) = JS0(KINT)+1
11152 JT0(KINT,INB) = JT0(KINT,INB)+1
11153 JI1(KINT,JNT0(KINT)) = INA
11154 JI2(KINT,JNT0(KINT)) = INB
11156 IF (JNT.GT.MAXINT) THEN
11157 WRITE(LOUT,1000) JNT, MAXINT
11159 & 'DIAGR: no. of requested interactions ('
11160 & ,I4,') exceeds array dimensions (',I4,')')
11163 JS(INA) = JS(INA)+1
11164 JT(INB) = JT(INB)+1
11174 IF (NTRY.LT.500) THEN
11177 C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11183 IF (IJPROJ.EQ.7) THEN
11184 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11186 IF (JNT0(K).EQ.0) THEN
11188 IF (K.GT.KINT) K = 1
11191 * supress Glauber-cascade by direct photon processes
11192 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11193 IF (IPNT.GT.0) THEN
11197 JT(INB) = JT0(K,INB)
11198 IF (JT(INB).GT.0) GOTO 12
11208 JT(INB) = JT0(K,INB)
11211 INTER1(I) = JI1(K,I)
11212 INTER2(I) = JI2(K,I)
11221 IF (JS(I).NE.0) INTA=INTA+1
11224 IF (JT(I).NE.0) INTB=INTB+1
11233 IF (NCOMPO.EQ.0) THEN
11235 NWA(INTA) = NWA(INTA)+1
11236 NWB(INTB) = NWB(INTB)+1
11242 *===modb===============================================================*
11245 SUBROUTINE DT_MODB(B,NIDX)
11247 ************************************************************************
11248 * Sampling of impact parameter of collision. *
11249 * B impact parameter (output) *
11250 * NIDX index of projectile/target material (input)*
11251 * Based on the original version by Shmakov et al. *
11252 * This version dated 21.04.95 is revised by S. Roesler *
11253 ************************************************************************
11255 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11258 PARAMETER ( LINP = 5 ,
11262 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11264 LOGICAL LEFT,LFIRST
11266 * central particle production, impact parameter biasing
11267 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11269 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11271 * Glauber formalism: parameters
11272 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11273 & BMAX(NCOMPX),BSTEP(NCOMPX),
11274 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11276 * Glauber formalism: cross sections
11277 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11278 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11279 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11280 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11281 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11282 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11283 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11284 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11285 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11286 & BSLOPE,NEBINI,NQBINI
11288 DATA LFIRST /.TRUE./
11291 IF (NIDX.LE.-1) THEN
11299 IF (ICENTR.EQ.2) THEN
11301 BB = DT_RNDM(B)*(0.3D0*RA)**2
11303 ELSEIF(RA.LT.RB)THEN
11304 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11306 ELSEIF(RA.GT.RB)THEN
11307 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11317 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11318 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11325 IF (I2-I0-2) 40,50,60
11328 IF (I1.GT.NSITEB) I1 = I0-1
11336 X0 = DBLE(I0-1)*BSTEP(NTARG)
11337 X1 = DBLE(I1-1)*BSTEP(NTARG)
11338 X2 = DBLE(I2-1)*BSTEP(NTARG)
11339 Y0 = BSITE(0,1,NTARG,I0)
11340 Y1 = BSITE(0,1,NTARG,I1)
11341 Y2 = BSITE(0,1,NTARG,I2)
11343 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11344 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11345 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11346 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11347 B = B+0.5D0*BSTEP(NTARG)
11348 IF (B.LT.ZERO) B = X1
11349 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11350 IF (ICENTR.LT.0) THEN
11353 IF (ICENTR.LE.-100) THEN
11358 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11359 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11360 & BIMIN,BIMAX,XSFRAC*100.0D0,
11361 & XSFRAC*XSPRO(1,1,NTARG)
11362 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11363 & /,15X,'---------------------------'/,/,4X,
11364 & 'average radii of proj / targ :',F10.3,' fm /',
11365 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11366 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11367 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11368 & ' cross section :',F10.3,' %',/,5X,
11369 & 'corresponding cross section :',F10.3,' mb',/)
11371 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11374 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11382 *===shfast=============================================================*
11384 CDECK ID>, DT_SHFAST
11385 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11387 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11390 PARAMETER ( LINP = 5 ,
11394 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11395 & ONE=1.0D0,TWO=2.0D0)
11397 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11399 * Glauber formalism: parameters
11400 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11401 & BMAX(NCOMPX),BSTEP(NCOMPX),
11402 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11404 * properties of interacting particles
11405 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11406 * Glauber formalism: cross sections
11407 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11408 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11409 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11410 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11411 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11412 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11413 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11414 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11415 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11416 & BSLOPE,NEBINI,NQBINI
11420 IF (MODE.EQ.2) THEN
11421 OPEN(47,FILE='shmakov.out',STATUS='UNKNOWN')
11422 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11423 1000 FORMAT(1X,8I5,E15.5)
11424 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11425 1001 FORMAT(1X,4E15.5)
11426 WRITE(47,1002) SIGSH,ROSH,GSH
11427 1002 FORMAT(1X,3E15.5)
11429 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11431 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11432 1003 FORMAT(1X,2I10,3E15.5)
11435 OPEN(47,FILE='shmakov.out',STATUS='UNKNOWN')
11436 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11437 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11438 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11439 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11440 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11441 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11442 READ(47,1002) SIGSH,ROSH,GSH
11444 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11446 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11456 *===poilik=============================================================*
11458 CDECK ID>, DT_POILIK
11459 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11461 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11464 PARAMETER ( LINP = 5 ,
11468 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11472 C CHARACTER*8 MDLNA
11473 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11474 C PARAMETER (IEETAB=10)
11475 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11477 C model switches and parameters
11479 INTEGER ISWMDL,IPAMDL
11480 DOUBLE PRECISION PARMDL
11481 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11482 C energy-interpolation table
11484 PARAMETER ( IEETA2 = 20 )
11486 DOUBLE PRECISION SIGTAB,SIGECM
11487 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11489 * VDM parameter for photon-nucleus interactions
11490 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11493 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11495 * Glauber formalism: cross sections
11496 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11497 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11498 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11499 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11500 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11501 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11502 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11503 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11504 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11505 & BSLOPE,NEBINI,NQBINI
11508 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11510 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11512 * load cross sections from interpolation table
11514 IF(ECM.LE.SIGECM(IP,1)) THEN
11517 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11519 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11525 WRITE(LOUT,'(/1X,A,2E12.3)')
11526 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11531 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11532 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11535 SIGANO = DT_SANO(ECM)
11537 * cross section dependence on photon virtuality
11540 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11541 & /(ONE+VIRT/PARMDL(30+I))**2
11543 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11553 C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11554 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11555 IF (ISHAD(1).EQ.1) THEN
11556 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11560 SIGANO = FSUP1*FSUP2*SIGANO
11561 SIGTOT = SIGTOT-SIGDIR-SIGANO
11562 SIGDIR = SIGDIR/(FSUP1*FSUP2)
11563 SIGANO = SIGANO/(FSUP1*FSUP2)
11564 SIGTOT = SIGTOT+SIGDIR+SIGANO
11566 RR = DT_RNDM(SIGTOT)
11567 IF (RR.LT.SIGDIR/SIGTOT) THEN
11569 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11570 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11575 RPNT = (SIGDIR+SIGANO)/SIGTOT
11576 C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11577 C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11578 C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11579 C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11580 IF (MODE.EQ.1) RETURN
11586 IF (ECM.GE.ECMNN(NEBINI)) THEN
11590 ELSEIF (ECM.GT.ECMNN(1)) THEN
11592 IF (ECM.LT.ECMNN(I)) THEN
11595 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11604 IF (NQBINI.GT.1) THEN
11605 IF (VIRT.GE.Q2G(NQBINI)) THEN
11609 ELSEIF (VIRT.GT.Q2G(1)) THEN
11611 IF (VIRT.LT.Q2G(I)) THEN
11614 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
11615 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11622 SGA = XSPRO(K1,J1,NTARG)+
11623 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11624 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11625 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11626 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11627 SDI = DBLE(NB)*SIGDIR
11628 SAN = DBLE(NB)*SIGANO
11631 IF (RR.LT.SDI/SGA) THEN
11633 ELSEIF ((RR.GE.SDI/SGA).AND.
11634 & (RR.LT.SPL/SGA)) THEN
11640 C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11646 *===glbini=============================================================*
11648 CDECK ID>, DT_GLBINI
11649 SUBROUTINE DT_GLBINI(WHAT)
11651 ************************************************************************
11652 * Pre-initialization of profile function *
11653 * This version dated 28.11.00 is written by S. Roesler. *
11654 ************************************************************************
11656 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11659 PARAMETER ( LINP = 5 ,
11663 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11667 * particle properties (BAMJET index convention)
11669 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11670 & IICH(210),IIBAR(210),K1(210),K2(210)
11671 * properties of interacting particles
11672 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11674 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11676 * emulsion treatment
11677 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11679 * Glauber formalism: flags and parameters for statistics
11682 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11683 * number of data sets other than protons and nuclei
11684 * at the moment = 2 (pions and kaons)
11685 PARAMETER (MAXOFF=2)
11686 DIMENSION IJPINI(5),IOFFST(25)
11687 DATA IJPINI / 13, 15, 0, 0, 0/
11688 * Glauber data-set to be used for hadron projectiles
11689 * (0=proton, 1=pion, 2=kaon)
11690 DATA (IOFFST(K),K=1,25) /
11691 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11693 * Acceptance interval for target nucleus mass
11694 PARAMETER (KBACC = 6)
11696 PARAMETER (MAXMSS = 100)
11697 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11700 DATA JPEACH,JPSTEP / 18, 5 /
11702 * temporary patch until fix has been implemented in phojet:
11703 * maximum energy for pion projectile
11704 DATA ECMXPI / 100000.0D0 /
11706 *--------------------------------------------------------------------------
11707 * general initializations
11709 * steps in projectile mass number for initialization
11710 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11711 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11713 * energy range and binning
11716 IF (ELO.GT.EHI) ELO = EHI
11717 NEBIN = MAX(INT(WHAT(3)),1)
11718 IF (ELO.EQ.EHI) NEBIN = 0
11719 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11723 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11724 & +2.0D0*AAM(IJTARG)*EHI)
11727 * default arguments for Glauber-routine
11731 * initialize nuclear parameters, etc.
11737 * open Glauber-data output file
11738 IDX = INDEX(CGLB,' ')
11740 IF (IDX.GT.1) K = IDX-1
11741 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11743 *--------------------------------------------------------------------------
11744 * Glauber-initialization for proton and nuclei projectiles
11746 * initialize phojet for proton-proton interactions
11749 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11752 * record projectile masses
11754 NPROJ = MIN(IP,JPEACH)
11755 DO 10 KPROJ=1,NPROJ
11757 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11758 IASAV(NASAV) = KPROJ
11760 IF (IP.GT.JPEACH) THEN
11761 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11762 IF (NPROJ.EQ.0) THEN
11764 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11767 DO 11 IPROJ=1,NPROJ
11768 KPROJ = JPEACH+IPROJ*JPSTEP
11770 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11771 IASAV(NASAV) = KPROJ
11773 IF (KPROJ.LT.IP) THEN
11775 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11781 * record target masses
11784 IF (NCOMPO.GT.0) NTARG = NCOMPO
11785 DO 12 ITARG=1,NTARG
11787 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11788 IF (NCOMPO.GT.0) THEN
11789 IBSAV(NBSAV) = IEMUMA(ITARG)
11796 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11797 1000 FORMAT(I4,A,1P,2E13.5)
11798 NLINES = DBLE(NASAV)/18.0D0
11799 IF (NLINES.GT.0) THEN
11802 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11804 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11809 IF (I0.LE.NASAV) THEN
11811 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11813 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11816 NLINES = DBLE(NBSAV)/18.0D0
11817 IF (NLINES.GT.0) THEN
11820 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11822 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11827 IF (I0.LE.NBSAV) THEN
11829 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11831 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11835 * calculate Glauber-data for each energy and mass combination
11837 * loop over energy bins
11840 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11842 E = ELO+DBLE(IE-1)*DEBIN
11845 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11850 E = MAX(AAM(IJPROJ)+0.1D0,E)
11851 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11854 * loop over projectile and target masses
11857 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11858 & XI,Q2I,ECM,1,1,-1)
11864 *--------------------------------------------------------------------------
11865 * Glauber-initialization for pion, kaon, ... projectiles
11869 * initialize phojet for this interaction
11872 IJPROJ = IJPINI(IJ)
11876 * temporary patch until fix has been implemented in phojet:
11877 IF (ECMINI.GT.ECMXPI) THEN
11878 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11880 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11884 * calculate Glauber-data for each energy and mass combination
11886 * loop over energy bins
11888 E = ELO+DBLE(IE-1)*DEBIN
11891 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11896 E = MAX(AAM(IJPROJ)+TINY14,E)
11897 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11900 * loop over projectile and target masses
11902 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11909 *--------------------------------------------------------------------------
11910 * close output unit(s), etc.
11917 *===glbset=============================================================*
11919 CDECK ID>, DT_GLBSET
11920 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11921 ************************************************************************
11922 * Interpolation of pre-initialized profile functions *
11923 * This version dated 28.11.00 is written by S. Roesler. *
11924 ************************************************************************
11926 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11929 PARAMETER ( LINP = 5 ,
11933 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11935 LOGICAL LCMS,LREAD,LFRST1,LFRST2
11937 * particle properties (BAMJET index convention)
11939 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11940 & IICH(210),IIBAR(210),K1(210),K2(210)
11941 * Glauber formalism: flags and parameters for statistics
11944 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11946 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11948 * Glauber formalism: parameters
11949 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11950 & BMAX(NCOMPX),BSTEP(NCOMPX),
11951 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11953 * Glauber formalism: cross sections
11954 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11955 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11956 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11957 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11958 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11959 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11960 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11961 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11962 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11963 & BSLOPE,NEBINI,NQBINI
11964 * number of data sets other than protons and nuclei
11965 * at the moment = 2 (pions and kaons)
11966 PARAMETER (MAXOFF=2)
11967 DIMENSION IJPINI(5),IOFFST(25)
11968 DATA IJPINI / 13, 15, 0, 0, 0/
11969 * Glauber data-set to be used for hadron projectiles
11970 * (0=proton, 1=pion, 2=kaon)
11971 DATA (IOFFST(K),K=1,25) /
11972 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11974 * Acceptance interval for target nucleus mass
11975 PARAMETER (KBACC = 6)
11976 * emulsion treatment
11977 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11980 PARAMETER (MAXSET=5000,
11982 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11983 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11984 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11987 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11989 * read data from file
11991 IF (MODE.EQ.0) THEN
12014 IDX = INDEX(CGLB,' ')
12016 IF (IDX.GT.1) K = IDX-1
12017 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12018 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12019 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
12022 * read binning information
12023 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12024 * return lower energy threshold to Fluka-interface
12027 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12029 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12031 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12033 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
12034 & 'No. of bins:',I5,/)
12035 ELO = LOG10(ABS(ELO))
12036 EHI = LOG10(ABS(EHI))
12037 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12038 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12039 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12040 IF (NABIN.LT.18) THEN
12041 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12043 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12045 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12046 IF (NABIN.GT.18) THEN
12047 NLINES = DBLE(NABIN-18)/18.0D0
12048 IF (NLINES.GT.0) THEN
12051 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12052 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12055 I0 = 18*(NLINES+1)+1
12056 IF (I0.LE.NABIN) THEN
12057 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12058 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12061 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12062 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12063 IF (NBBIN.LT.18) THEN
12064 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12066 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12068 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12069 IF (NBBIN.GT.18) THEN
12070 NLINES = DBLE(NBBIN-18)/18.0D0
12071 IF (NLINES.GT.0) THEN
12074 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12075 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12078 I0 = 18*(NLINES+1)+1
12079 IF (I0.LE.NBBIN) THEN
12080 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12081 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12084 * number of data sets to follow in the Glauber data file
12085 * this variable is used for checks of consistency of projectile
12086 * and target mass configurations given in header of Glauber data
12087 * file and the data-sets which follow in this file
12088 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12090 * read profile function data
12096 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12097 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12098 1002 FORMAT(5I10,E15.5)
12099 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12101 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12105 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12106 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12107 NLINES = INT(DBLE(ISITEB)/7.0D0)
12108 IF (NLINES.GT.0) THEN
12110 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12115 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12119 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12120 WRITE(LOUT,'(/,1X,A)')
12121 & ' projectiles other than protons and nuclei: (particle index)'
12122 IF (NAIDX.GT.0) THEN
12123 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12125 WRITE(LOUT,'(6X,A)') 'none'
12132 IF (NCOMPO.EQ.0) THEN
12135 IEMUMA(NCOMPO) = IBBIN(J)
12136 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12137 EMUFRA(NCOMPO) = 1.0D0
12142 * calculate profile function for certain set of parameters
12146 c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12148 * check for type of projectile and set index-offset to entry in
12149 * Glauber data array correspondingly
12150 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12151 IF (IOFFST(IDPROJ).EQ.-1) THEN
12152 STOP ' GLBSET: no data for this projectile !'
12153 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12154 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12159 * get energy bin and interpolation factor
12161 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12168 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12175 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12180 IE0 = (E-ELO)/DEBIN+1
12182 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12184 * get target nucleus index
12188 NBDIFF = ABS(NB-IBBIN(I))
12189 IF (NB.EQ.IBBIN(I)) THEN
12192 ELSEIF (NBDIFF.LE.NBACC) THEN
12197 IF (KB.NE.0) GOTO 21
12198 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12202 * get projectile nucleus bin and interpolation factor
12206 IF (IDXOFF.GT.0) THEN
12211 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12213 IF (NA.EQ.IABIN(I)) THEN
12217 ELSEIF (NA.LT.IABIN(I)) THEN
12223 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12227 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12231 * interpolate profile functions for interactions ka0-kb and ka1-kb
12232 * for energy E separately
12233 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12234 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12235 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12236 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12238 BPRO0(I) = BPROFL(IDX0,I)
12239 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12240 BPRO1(I) = BPROFL(IDY0,I)
12241 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12243 RADB = DT_RNCLUS(NB)
12244 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12245 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12247 * interpolate cross sections for energy E and projectile mass
12249 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12250 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12251 XS(I) = XS0+FACNA*(XS1-XS0)
12252 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12253 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12254 XE(I) = XE0+FACNA*(XE1-XE0)
12257 * interpolate between ka0 and ka1
12258 RADA = DT_RNCLUS(NA)
12259 BMX = 2.0D0*(RADA+RADB)
12260 BSTP = BMX/DBLE(ISITEB-1)
12265 * calculate values of profile functions at B
12267 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12268 IDX1 = MIN(IDX0+1,ISITEB)
12269 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12270 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12272 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12273 IDX1 = MIN(IDX0+1,ISITEB)
12274 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12275 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12277 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12280 * fill common dtglam
12287 BSITE(0,1,1,I) = BPRO(I)
12290 * fill common dtglxs
12291 XSTOT(1,1,1) = XS(1)
12292 XSELA(1,1,1) = XS(2)
12293 XSQEP(1,1,1) = XS(3)
12294 XSQET(1,1,1) = XS(4)
12295 XSQE2(1,1,1) = XS(5)
12296 XSPRO(1,1,1) = XS(6)
12297 XETOT(1,1,1) = XE(1)
12298 XEELA(1,1,1) = XE(2)
12299 XEQEP(1,1,1) = XE(3)
12300 XEQET(1,1,1) = XE(4)
12301 XEQE2(1,1,1) = XE(5)
12302 XEPRO(1,1,1) = XE(6)
12309 *===xksamp=============================================================*
12311 CDECK ID>, DT_XKSAMP
12312 SUBROUTINE DT_XKSAMP(NN,ECM)
12314 ************************************************************************
12315 * Sampling of parton x-values and chain system for one interaction. *
12316 * processed by S. Roesler, 9.8.95 *
12317 ************************************************************************
12319 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12322 PARAMETER ( LINP = 5 ,
12326 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12330 * lower cuts for (valence-sea/sea-valence) chain masses
12331 * antiquark-quark (u/d-sea quark) (s-sea quark)
12332 & AMIU = 0.5D0, AMIS = 0.8D0,
12333 * quark-diquark (u/d-sea quark) (s-sea quark)
12334 & AMAU = 2.6D0, AMAS = 2.6D0,
12335 * maximum lower valence-x threshold
12337 * fraction of sea-diquarks sampled out of sea-partons
12339 C & FRCDIQ = 0.9D0,
12344 * maximum number of trials to generate x's for the required number
12345 * of sea quark pairs for a given hadron
12350 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12352 PARAMETER ( MAXNCL = 260,
12355 & MAXSQU = 20*MAXVQU,
12356 & MAXINT = MAXVQU+MAXSQU)
12359 PARAMETER (NMXHKK=200000)
12361 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12362 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12363 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12364 * particle properties (BAMJET index convention)
12366 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12367 & IICH(210),IIBAR(210),K1(210),K2(210)
12368 * interface between Glauber formalism and DPM
12369 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12370 & INTER1(MAXINT),INTER2(MAXINT)
12371 * properties of interacting particles
12372 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12373 * threshold values for x-sampling (DTUNUC 1.x)
12374 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12376 * x-values of partons (DTUNUC 1.x)
12377 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12378 & XTVQ(MAXVQU),XTVD(MAXVQU),
12379 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12380 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12381 * flavors of partons (DTUNUC 1.x)
12382 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12383 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12384 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12385 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12386 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12387 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12388 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12389 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12390 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12391 & IXPV,IXPS,IXTV,IXTS,
12392 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12393 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12394 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12395 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12396 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12397 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12398 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12399 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12400 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12401 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12402 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12403 * auxiliary common for chain system storage (DTUNUC 1.x)
12404 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12405 * flags for input different options
12406 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12407 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12408 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12409 * various options for treatment of partons (DTUNUC 1.x)
12410 * (chain recombination, Cronin,..)
12411 LOGICAL LCO2CR,LINTPT
12412 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12415 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12418 * (1) initializations
12419 *-----------------------------------------------------------------------
12422 IF (ECM.LT.4.5D0) THEN
12425 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12426 C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12427 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12436 IF (I.LE.MAXVQU) THEN
12442 * lower thresholds for x-selection
12443 * sea-quarks (default: CSEA=0.2)
12444 IF (ECM.LT.10.0D0) THEN
12446 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12447 C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12449 C XSTHR = ONE/ECM**2
12453 XSTHR = CSEA/ECM**2
12454 C XSTHR = ONE/ECM**2
12456 IF ((IP.GE.150).AND.(IT.GE.150))
12457 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12460 * (default: SSMIMA=0.14) used for sea-diquarks (?)
12461 XSSTHR = SSMIMA/ECM
12463 * valence-quarks (default: CVQ=1.0)
12465 * valence-diquarks (default: CDQ=2.0)
12468 * maximum-x for sea-quarks
12469 XVCUT = XVTHR+XDTHR
12470 IF (XVCUT.GT.XVMAX) THEN
12472 XVTHR = XVCUT/3.0D0
12473 XDTHR = XVCUT-XVTHR
12476 **sr 18.4. test: DPMJET
12477 C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12478 C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12479 C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12481 * maximum number of sea-pairs allowed kinematically
12482 C NSMAX = INT(OHALF*XXSEAM/XSTHR)
12483 RNSMAX = OHALF*XXSEAM/XSTHR
12484 IF (RNSMAX.GT.10000.0D0) THEN
12487 NSMAX = INT(OHALF*XXSEAM/XSTHR)
12489 * check kinematical limit for valence-x thresholds
12490 * (should be obsolete now)
12491 IF (XVCUT.GT.XVMAX) THEN
12492 WRITE(LOUT,1000) XVCUT,ECM
12493 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
12494 & ' thresholds not allowed (',2E9.3,')')
12495 C XVTHR = XVMAX-XDTHR
12496 C IF (XVTHR.LT.ZERO) STOP
12500 * set eta for valence-x sampling (BETREJ)
12501 * (UNON per default, UNOM used for projectile mesons only)
12502 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12508 * (2) select parton x-values of interacting projectile nucleons
12509 *-----------------------------------------------------------------------
12515 * get interacting projectile nucleon as sampled by Glauber
12516 IF (JSSH(IPP).NE.0) THEN
12522 * JIPP is the actual number of sea-pairs sampled for this nucleon
12523 JIPP = MIN(JSSH(IPP)-1,NSMAX)
12526 IF (JIPP.GT.0) THEN
12527 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12529 IF (XSTHR.GE.XSMAX) THEN
12534 *>>>get x-values of sea-quark pairs
12538 * accumulator for sea x-values
12541 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12542 IF (NSCOUN.GT.NSEA) THEN
12543 * decrease the number of interactions after NSEA trials
12549 IF (IPSQ(IXPS+1).LE.2) THEN
12550 **sr 8.4.98 (1/sqrt(x))
12551 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12552 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12553 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12556 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12557 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12559 **sr 8.4.98 (1/sqrt(x))
12560 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12561 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12562 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12567 IF (IPSAQ(IXPS+1).GE.-2) THEN
12568 **sr 8.4.98 (1/sqrt(x))
12569 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12570 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12571 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12574 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12575 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12577 **sr 8.4.98 (1/sqrt(x))
12578 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12579 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12580 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12584 XXSEA = XXSEA+XPSQI+XPSAQI
12585 * check for maximum allowed sea x-value
12586 IF (XXSEA.GE.XXSEAM) THEN
12590 * accept this sea-quark pair
12593 XPSAQ(IXPS) = XPSAQI
12595 ZUOSP(IXPS) = .TRUE.
12599 *>>>get x-values of valence partons
12601 IF (XVTHR.GT.0.05D0) THEN
12602 XVHI = ONE-XXSEA-XDTHR
12603 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12606 XPVQI = DT_DBETAR(OHALF,UNOPRV)
12607 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12611 XPVDI = ONE-XPVQI-XXSEA
12612 * reject according to x**1.5
12613 XDTMP = XPVDI**1.5D0
12614 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12615 * accept these valence partons
12621 ZUOVP(IXPV) = .TRUE.
12626 * (3) select parton x-values of interacting target nucleons
12627 *-----------------------------------------------------------------------
12633 * get interacting target nucleon as sampled by Glauber
12634 IF (JTSH(ITT).NE.0) THEN
12640 * JITT is the actual number of sea-pairs sampled for this nucleon
12641 JITT = MIN(JTSH(ITT)-1,NSMAX)
12644 IF (JITT.GT.0) THEN
12645 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12647 IF (XSTHR.GE.XSMAX) THEN
12652 *>>>get x-values of sea-quark pairs
12656 * accumulator for sea x-values
12659 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12660 IF (NSCOUN.GT.NSEA)THEN
12661 * decrease the number of interactions after NSEA trials
12667 IF (ITSQ(IXTS+1).LE.2) THEN
12668 **sr 8.4.98 (1/sqrt(x))
12669 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12670 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12671 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12674 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12675 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12677 **sr 8.4.98 (1/sqrt(x))
12678 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12679 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12680 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12685 IF (ITSAQ(IXTS+1).GE.-2) THEN
12686 **sr 8.4.98 (1/sqrt(x))
12687 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12688 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12689 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12692 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12693 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12695 **sr 8.4.98 (1/sqrt(x))
12696 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12697 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12698 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12702 XXSEA = XXSEA+XTSQI+XTSAQI
12703 * check for maximum allowed sea x-value
12704 IF (XXSEA.GE.XXSEAM) THEN
12708 * accept this sea-quark pair
12711 XTSAQ(IXTS) = XTSAQI
12713 ZUOST(IXTS) = .TRUE.
12717 *>>>get x-values of valence partons
12719 IF (XVTHR.GT.0.05D0) THEN
12720 XVHI = ONE-XXSEA-XDTHR
12721 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12724 XTVQI = DT_DBETAR(OHALF,UNON)
12725 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12729 XTVDI = ONE-XTVQI-XXSEA
12730 * reject according to x**1.5
12731 XDTMP = XTVDI**1.5D0
12732 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12733 * accept these valence partons
12739 ZUOVT(IXTV) = .TRUE.
12744 * (4) get valence-valence chains
12745 *-----------------------------------------------------------------------
12750 IPVAL = ITOVP(INTER1(I))
12751 ITVAL = ITOVT(INTER2(I))
12752 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12754 ZUOVP(IPVAL) = .FALSE.
12755 ZUOVT(ITVAL) = .FALSE.
12758 INTVV1(NVV) = IPVAL
12759 INTVV2(NVV) = ITVAL
12763 * (5) get sea-valence chains
12764 *-----------------------------------------------------------------------
12771 IPVAL = ITOVP(INTER1(I))
12772 ITVAL = ITOVT(INTER2(I))
12774 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12775 & ZUOVT(ITVAL)) THEN
12777 ZUOVT(ITVAL) = .FALSE.
12779 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12780 * sample sea-diquark pair
12781 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12782 IF (IREJ1.EQ.0) GOTO 260
12787 INTSV2(NSV) = ITVAL
12789 *>>>correct chain kinematics according to minimum chain masses
12790 * the actual chain masses
12791 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12792 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12793 * get lower mass cuts
12794 IF (IPSQ(J).EQ.3) THEN
12799 * q being u/d-quark
12804 * chain mass above minimum - resampling of sea-q x-value
12805 IF (AMSVQ1.GT.AMCHK1) THEN
12806 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
12807 **sr 8.4.98 (1/sqrt(x))
12808 C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
12809 C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
12810 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12812 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12814 * chain mass below minimum - reset sea-q x-value and correct
12815 * diquark-x of the same nucleon
12816 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12817 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
12818 DXPSQ = XPSQW-XPSQ(J)
12819 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12820 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12825 * chain mass below minimum - reset sea-aq x-value and correct
12826 * diquark-x of the same nucleon
12827 IF (AMSVQ2.LT.AMCHK2) THEN
12828 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12829 DXPSQ = XPSQW-XPSAQ(J)
12830 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12831 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12835 *>>>end of chain mass correction
12844 * (6) get valence-sea chains
12845 *-----------------------------------------------------------------------
12851 IPVAL = ITOVP(INTER1(I))
12852 ITVAL = ITOVT(INTER2(I))
12854 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12855 & (IFROST(J).EQ.INTER2(I))) THEN
12857 ZUOVP(IPVAL) = .FALSE.
12859 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12860 * sample sea-diquark pair
12861 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12862 IF (IREJ1.EQ.0) GOTO 290
12866 INTVS1(NVS) = IPVAL
12869 *>>>correct chain kinematics according to minimum chain masses
12870 * the actual chain masses
12871 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12872 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12873 * get lower mass cuts
12874 IF (ITSQ(J).EQ.3) THEN
12879 * q being u/d-quark
12884 * chain mass below minimum - reset sea-aq x-value and correct
12885 * diquark-x of the same nucleon
12886 IF (AMVSQ1.LT.AMCHK1) THEN
12887 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12888 DXTSQ = XTSQW-XTSAQ(J)
12889 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12890 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12895 * chain mass above minimum - resampling of sea-q x-value
12896 IF (AMVSQ2.GT.AMCHK2) THEN
12897 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
12898 **sr 8.4.98 (1/sqrt(x))
12899 C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
12900 C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
12901 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12903 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12905 * chain mass below minimum - reset sea-q x-value and correct
12906 * diquark-x of the same nucleon
12907 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12908 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
12909 DXTSQ = XTSQW-XTSQ(J)
12910 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12911 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12915 *>>>end of chain mass correction
12924 * (7) get sea-sea chains
12925 *-----------------------------------------------------------------------
12932 IPVAL = ITOVP(INTER1(I))
12933 ITVAL = ITOVT(INTER2(I))
12934 * loop over target partons not yet matched
12936 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12937 * loop over projectile partons not yet matched
12939 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12940 ZUOSP(JJ) = .FALSE.
12948 *---->chain recombination option
12949 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
12950 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12952 * sea-sea chains may recombine with valence-valence chains
12953 * only if they have the same projectile or target nucleon
12955 IF (ISKPCH(8,IVV).NE.99) THEN
12956 IXVPR = INTVV1(IVV)
12957 IXVTA = INTVV2(IVV)
12958 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12959 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12960 * recombination possible, drop old v-v and s-s chains
12964 * (a) assign new s-v chains
12965 * ~~~~~~~~~~~~~~~~~~~~~~~~~
12967 & (DT_RNDM(VALFRA).GT.FRCDIQ))
12969 * sample sea-diquark pair
12970 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12972 IF (IREJ1.EQ.0) GOTO 4202
12977 INTSV2(NSV) = IXVTA
12978 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12979 * the actual chain masses
12980 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12982 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12984 * get lower mass cuts
12985 IF (IPSQ(JJ).EQ.3) THEN
12990 * q being u/d-quark
12995 * chain mass above minimum - resampling of sea-q x-value
12996 IF (AMSVQ1.GT.AMCHK1) THEN
12998 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12999 **sr 8.4.98 (1/sqrt(x))
13001 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13002 C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
13003 C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
13006 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13008 * chain mass below minimum - reset sea-q x-value and correct
13009 * diquark-x of the same nucleon
13010 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13012 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13013 DXPSQ = XPSQW-XPSQ(JJ)
13014 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13017 & XPVD(IPVAL)-DXPSQ
13022 * chain mass below minimum - reset sea-aq x-value and correct
13023 * diquark-x of the same nucleon
13024 IF (AMSVQ2.LT.AMCHK2) THEN
13026 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
13027 DXPSQ = XPSQW-XPSAQ(JJ)
13028 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13031 & XPVD(IPVAL)-DXPSQ
13035 *>>>>>>>>>>>end of chain mass correction
13038 * (b) assign new v-s chains
13039 * ~~~~~~~~~~~~~~~~~~~~~~~~~
13041 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
13043 * sample sea-diquark pair
13044 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13046 IF (IREJ1.EQ.0) GOTO 4203
13050 INTVS1(NVS) = IXVPR
13052 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13053 * the actual chain masses
13054 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13055 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13056 * get lower mass cuts
13057 IF (ITSQ(J).EQ.3) THEN
13062 * q being u/d-quark
13067 * chain mass below minimum - reset sea-aq x-value and correct
13068 * diquark-x of the same nucleon
13069 IF (AMVSQ1.LT.AMCHK1) THEN
13071 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
13072 DXTSQ = XTSQW-XTSAQ(J)
13073 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13076 & XTVD(ITVAL)-DXTSQ
13080 IF (AMVSQ2.GT.AMCHK2) THEN
13082 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13083 **sr 8.4.98 (1/sqrt(x))
13085 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13086 C & DT_SAMSQX(XTSQTH,XTSQ(J))
13087 C & DT_SAMPEX(XTSQTH,XTSQ(J))
13090 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13092 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13094 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13095 DXTSQ = XTSQW-XTSQ(J)
13096 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13099 & XTVD(ITVAL)-DXTSQ
13103 *>>>>>>>>>end of chain mass correction
13105 * jump out of s-s chain loop
13111 *---->end of chain recombination option
13113 * sample sea-diquark pair (projectile)
13114 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13115 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13116 IF (IREJ1.EQ.0) THEN
13121 * sample sea-diquark pair (target)
13122 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13123 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13124 IF (IREJ1.EQ.0) THEN
13129 *>>>>>correct chain kinematics according to minimum chain masses
13130 * the actual chain masses
13131 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13132 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13133 * check for lower mass cuts
13134 IF ((SSMA1Q.LT.SSMIMQ).OR.
13135 & (SSMA2Q.LT.SSMIMQ)) THEN
13136 IPVAL = ITOVP(INTER1(I))
13137 ITVAL = ITOVT(INTER2(I))
13138 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13139 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13140 * maximum allowed x values for sea quarks
13141 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13143 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13145 * resampling of x values not possible - skip sea-sea chains
13146 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13147 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13148 * resampling of x for projectile sea quark pair
13152 IF (XSSTHR.GT.0.05D0) THEN
13153 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13155 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13159 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13160 IF ((XPSQI.LT.XSSTHR).OR.
13161 & (XPSQI.GT.XSPMAX)) GOTO 320
13163 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13164 IF ((XPSAQI.LT.XSSTHR).OR.
13165 & (XPSAQI.GT.XSPMAX)) GOTO 330
13167 * final test of remaining x for projectile diquark
13168 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13169 & +XPSQ(JJ)+XPSAQ(JJ)
13170 IF (XPVDCO.LE.XDTHR) THEN
13172 C IF (ICOUS.LT.5) GOTO 310
13173 IF (ICOUS.LT.0.5D0) GOTO 310
13176 * resampling of x for target sea quark pair
13180 IF (XSSTHR.GT.0.05D0) THEN
13181 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13183 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13187 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13188 IF ((XTSQI.LT.XSSTHR).OR.
13189 & (XTSQI.GT.XSTMAX)) GOTO 360
13191 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13192 IF ((XTSAQI.LT.XSSTHR).OR.
13193 & (XTSAQI.GT.XSTMAX)) GOTO 370
13195 * final test of remaining x for target diquark
13196 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13197 & +XTSQ(J)+XTSAQ(J)
13198 IF (XTVDCO.LT.XDTHR) THEN
13199 IF (ICOUS.LT.5) GOTO 350
13202 XPVD(IPVAL) = XPVDCO
13203 XTVD(ITVAL) = XTVDCO
13208 *>>>>>end of chain mass correction
13211 * come here to discard s-s interaction
13212 * resampling of x values not allowed or unsuccessful
13219 * consider next s-s interaction
13229 * correct x-values of valence quarks for non-matching sea quarks
13232 IPVAL = ITOVP(IFROSP(I))
13233 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13241 ITVAL = ITOVT(IFROST(I))
13242 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13249 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13252 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13258 *===samsdq=============================================================*
13260 CDECK ID>, DT_SAMSDQ
13261 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13263 ************************************************************************
13264 * SAMpling of Sea-DiQuarks *
13265 * ECM cm-energy of the nucleon-nucleon system *
13266 * IDX1,2 indices of x-values of the participating *
13267 * partons (IDX2 is always the sea-q-pair to be *
13268 * changed to sea-qq-pair) *
13269 * MODE = 1 valence-q - sea-diq *
13270 * = 2 sea-diq - valence-q *
13271 * = 3 sea-q - sea-diq *
13272 * = 4 sea-diq - sea-q *
13273 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13274 * This version dated 17.10.95 is written by S. Roesler *
13275 ************************************************************************
13277 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13280 PARAMETER (ZERO=0.0D0)
13282 * threshold values for x-sampling (DTUNUC 1.x)
13283 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13285 * various options for treatment of partons (DTUNUC 1.x)
13286 * (chain recombination, Cronin,..)
13287 LOGICAL LCO2CR,LINTPT
13288 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13291 PARAMETER ( MAXNCL = 260,
13294 & MAXSQU = 20*MAXVQU,
13295 & MAXINT = MAXVQU+MAXSQU)
13296 * x-values of partons (DTUNUC 1.x)
13297 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13298 & XTVQ(MAXVQU),XTVD(MAXVQU),
13299 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13300 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13301 * flavors of partons (DTUNUC 1.x)
13302 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13303 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13304 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13305 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13306 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13307 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13308 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13309 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13310 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13311 & IXPV,IXPS,IXTV,IXTS,
13312 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13313 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13314 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13315 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13316 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13317 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13318 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13319 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13320 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13321 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13322 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13323 * auxiliary common for chain system storage (DTUNUC 1.x)
13324 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13327 * threshold-x for valence diquarks
13330 GOTO (1,2,3,4) MODE
13332 *---------------------------------------------------------------------
13333 * proj. valence partons - targ. sea partons
13334 * get x-values and flavors for target sea-diquark pair
13340 * index of corr. val-diquark-x in target nucleon
13341 IDXVT = ITOVT(IFROST(IDXST))
13342 * available x above diquark thresholds for valence- and sea-diquarks
13343 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13345 IF (XXD.GE.ZERO) THEN
13346 * x-values for the three diquarks of the target nucleon
13350 SR123 = RR1+RR2+RR3
13351 XXTV = XDTHR+RR1*XXD/SR123
13352 XXTSQ = XDTHR+RR2*XXD/SR123
13353 XXTSAQ = XDTHR+RR3*XXD/SR123
13356 XXTSQ = XTSQ(IDXST)
13357 XXTSAQ = XTSAQ(IDXST)
13359 * flavor of the second quarks in the sea-diquark pair
13360 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13361 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13362 * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13363 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13364 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13365 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13367 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13370 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13371 * at least one strange quark
13372 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13375 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13379 * accept the new sea-diquark
13381 XTSQ(IDXST) = XXTSQ
13382 XTSAQ(IDXST) = XXTSAQ
13384 INTVD1(NVD) = IDXVP
13385 INTVD2(NVD) = IDXST
13389 *---------------------------------------------------------------------
13390 * proj. sea partons - targ. valence partons
13391 * get x-values and flavors for projectile sea-diquark pair
13397 * index of corr. val-diquark-x in projectile nucleon
13398 IDXVP = ITOVP(IFROSP(IDXSP))
13399 * available x above diquark thresholds for valence- and sea-diquarks
13400 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13402 IF (XXD.GE.ZERO) THEN
13403 * x-values for the three diquarks of the projectile nucleon
13407 SR123 = RR1+RR2+RR3
13408 XXPV = XDTHR+RR1*XXD/SR123
13409 XXPSQ = XDTHR+RR2*XXD/SR123
13410 XXPSAQ = XDTHR+RR3*XXD/SR123
13413 XXPSQ = XPSQ(IDXSP)
13414 XXPSAQ = XPSAQ(IDXSP)
13416 * flavor of the second quarks in the sea-diquark pair
13417 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13418 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13419 * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13420 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13421 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13422 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13424 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13427 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13428 * at least one strange quark
13429 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13432 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13436 * accept the new sea-diquark
13438 XPSQ(IDXSP) = XXPSQ
13439 XPSAQ(IDXSP) = XXPSAQ
13441 INTDV1(NDV) = IDXSP
13442 INTDV2(NDV) = IDXVT
13446 *---------------------------------------------------------------------
13447 * proj. sea partons - targ. sea partons
13448 * get x-values and flavors for target sea-diquark pair
13454 * index of corr. val-diquark-x in target nucleon
13455 IDXVT = ITOVT(IFROST(IDXST))
13456 * available x above diquark thresholds for valence- and sea-diquarks
13457 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13459 IF (XXD.GE.ZERO) THEN
13460 * x-values for the three diquarks of the target nucleon
13464 SR123 = RR1+RR2+RR3
13465 XXTV = XDTHR+RR1*XXD/SR123
13466 XXTSQ = XDTHR+RR2*XXD/SR123
13467 XXTSAQ = XDTHR+RR3*XXD/SR123
13470 XXTSQ = XTSQ(IDXST)
13471 XXTSAQ = XTSAQ(IDXST)
13473 * flavor of the second quarks in the sea-diquark pair
13474 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13475 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13476 * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13477 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
13478 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13479 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13481 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13484 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13485 * at least one strange quark
13486 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13489 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13493 * accept the new sea-diquark
13495 XTSQ(IDXST) = XXTSQ
13496 XTSAQ(IDXST) = XXTSAQ
13498 INTSD1(NSD) = IDXSP
13499 INTSD2(NSD) = IDXST
13503 *---------------------------------------------------------------------
13504 * proj. sea partons - targ. sea partons
13505 * get x-values and flavors for projectile sea-diquark pair
13511 * index of corr. val-diquark-x in projectile nucleon
13512 IDXVP = ITOVP(IFROSP(IDXSP))
13513 * available x above diquark thresholds for valence- and sea-diquarks
13514 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13516 IF (XXD.GE.ZERO) THEN
13517 * x-values for the three diquarks of the projectile nucleon
13521 SR123 = RR1+RR2+RR3
13522 XXPV = XDTHR+RR1*XXD/SR123
13523 XXPSQ = XDTHR+RR2*XXD/SR123
13524 XXPSAQ = XDTHR+RR3*XXD/SR123
13527 XXPSQ = XPSQ(IDXSP)
13528 XXPSAQ = XPSAQ(IDXSP)
13530 * flavor of the second quarks in the sea-diquark pair
13531 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13532 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13533 * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13534 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
13535 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
13536 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13538 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13541 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13542 * at least one strange quark
13543 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13546 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13550 * accept the new sea-diquark
13552 XPSQ(IDXSP) = XXPSQ
13553 XPSAQ(IDXSP) = XXPSAQ
13555 INTDS1(NDS) = IDXSP
13556 INTDS2(NDS) = IDXST
13561 *===difevt=============================================================*
13563 CDECK ID>, DT_DIFEVT
13564 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13565 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13567 ************************************************************************
13568 * Interface to treatment of diffractive interactions. *
13569 * (input) IFP1/2 PDG-indizes of projectile partons *
13570 * (baryon: IFP2 - adiquark) *
13571 * PP(4) projectile 4-momentum *
13572 * IFT1/2 PDG-indizes of target partons *
13573 * (baryon: IFT1 - adiquark) *
13574 * PT(4) target 4-momentum *
13575 * (output) JDIFF = 0 no diffraction *
13576 * = 1/-1 LMSD/LMDD *
13577 * = 2/-2 HMSD/HMDD *
13578 * NCSY counter for two-chain systems *
13579 * dumped to DTEVT1 *
13580 * This version dated 14.02.95 is written by S. Roesler *
13581 ************************************************************************
13583 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13586 PARAMETER ( LINP = 5 ,
13590 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13595 PARAMETER (NMXHKK=200000)
13597 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13598 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13599 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13600 * extended event history
13601 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13602 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13604 * flags for diffractive interactions (DTUNUC 1.x)
13605 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13607 DIMENSION PP(4),PT(4)
13610 DATA LFIRST /.TRUE./
13617 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13618 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13619 * identities of projectile hadron / target nucleon
13620 KPROJ = IDT_ICIHAD(IDHKK(MOP))
13621 KTARG = IDT_ICIHAD(IDHKK(MOT))
13623 * single diffractive xsections
13624 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13625 * double diffractive xsections
13626 **!! no double diff yet
13627 C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13631 * total inelastic xsection
13632 C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13634 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13635 SIGIN = MAX(SIGTO-SIGEL,ZERO)
13637 * fraction of diffractive processes
13638 FRADIF = (SDTOT+DDTOT)/SIGIN
13641 WRITE(LOUT,1000) XM,SDTOT,SIGIN
13642 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13643 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13648 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13649 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13650 * diffractive interaction requested by x-section or by user
13651 FRASD = SDTOT/(SDTOT+DDTOT)
13652 FRASDH = SDHM/SDTOT
13653 **sr needs to be specified!!
13654 C FRADDH = DDHM/DDTOT
13657 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13658 * single diffraction
13660 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13663 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13664 & ISINGD.NE.3) THEN
13671 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13672 & ISINGD.NE.3) THEN
13678 * double diffraction
13680 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13688 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13689 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13690 IF (IREJ1.EQ.0) THEN
13692 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13706 *===difkin=============================================================*
13708 CDECK ID>, DT_DIFFKI
13709 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13710 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13712 ************************************************************************
13713 * Kinematics of diffractive nucleon-nucleon interaction. *
13714 * IFP1/2 PDG-indizes of projectile partons *
13715 * (baryon: IFP2 - adiquark) *
13716 * PP(4) projectile 4-momentum *
13717 * IFT1/2 PDG-indizes of target partons *
13718 * (baryon: IFT1 - adiquark) *
13719 * PT(4) target 4-momentum *
13720 * KP = 0 projectile quasi-elastically scattered *
13721 * = 1 excited to low-mass diff. state *
13722 * = 2 excited to high-mass diff. state *
13723 * KT = 0 target quasi-elastically scattered *
13724 * = 1 excited to low-mass diff. state *
13725 * = 2 excited to high-mass diff. state *
13726 * This version dated 12.02.95 is written by S. Roesler *
13727 ************************************************************************
13729 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13732 PARAMETER ( LINP = 5 ,
13736 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13740 * particle properties (BAMJET index convention)
13742 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13743 & IICH(210),IIBAR(210),K1(210),K2(210)
13744 * flags for input different options
13745 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13746 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13747 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13748 * rejection counter
13749 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13750 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13751 & IREXCI(3),IRDIFF(2),IRINC
13752 * kinematics of diffractive interactions (DTUNUC 1.x)
13753 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13755 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13756 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13758 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13759 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13761 DATA LSTART /.TRUE./
13765 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
13771 * initialize common /DTDIKI/
13773 * store momenta of initial incoming particles for emc-check
13775 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13776 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13779 * masses of initial particles
13780 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13781 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13782 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13785 * check quark-input (used to adjust coherence cond. for M-selection)
13787 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13789 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13791 * parameter for Lorentz-transformation into nucleon-nucleon cms
13793 PITOT(K) = PP(K)+PT(K)
13795 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13796 IF (XMTOT2.LE.ZERO) THEN
13797 WRITE(LOUT,1000) XMTOT2
13798 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
13799 & 'XMTOT2 = ',E12.3)
13802 XMTOT = SQRT(XMTOT2)
13804 BGTOT(K) = PITOT(K)/XMTOT
13806 * transformation of nucleons into cms
13807 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13808 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13809 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13810 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13813 C SID = SQRT((ONE-COD)*(ONE+COD))
13814 PPT = SQRT(PP1(1)**2+PP1(2)**2)
13818 IF(PPTOT*SID.GT.TINY10) THEN
13819 COF = PP1(1)/(SID*PPTOT)
13820 SIF = PP1(2)/(SID*PPTOT)
13821 ANORF = SQRT(COF*COF+SIF*SIF)
13825 * check consistency
13827 DEV1(K) = ABS(PP1(K)+PT1(K))
13829 DEV1(4) = ABS(DEV1(4)-XMTOT)
13830 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13831 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
13832 WRITE(LOUT,1001) DEV1
13833 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
13838 * select x-fractions in high-mass diff. interactions
13839 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13841 * select diffractive masses
13844 XMPF = DT_XMLMD(XMTOT)
13845 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13846 IF (IREJ1.GT.0) GOTO 9999
13847 ELSEIF (KP.EQ.2) THEN
13848 XMPF = DT_XMHMD(XMTOT,IBP,1)
13854 XMTF = DT_XMLMD(XMTOT)
13855 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13856 IF (IREJ1.GT.0) GOTO 9999
13857 ELSEIF (KT.EQ.2) THEN
13858 XMTF = DT_XMHMD(XMTOT,IBT,2)
13863 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13866 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13867 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13869 * select momentum transfer (all t-values used here are <0)
13870 * minimum absolute value to produce diffractive masses
13871 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13872 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13873 IF (IREJ1.GT.0) GOTO 9999
13875 * longitudinal momentum of excited/elastically scattered projectile
13876 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13877 * total transverse momentum due to t-selection
13878 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13879 IF (PPBLT2.LT.ZERO) THEN
13880 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13881 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
13882 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13885 CALL DT_DSFECF(SINPHI,COSPHI)
13886 PPBLT = SQRT(PPBLT2)
13887 PPBLOB(1) = COSPHI*PPBLT
13888 PPBLOB(2) = SINPHI*PPBLT
13890 * rotate excited/elastically scattered projectile into n-n cms.
13891 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13897 * 4-momentum of excited/elastically scattered target and of exchanged
13900 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13901 PPOM1(K) = PP1(K)-PPBLOB(K)
13903 PTBLOB(4) = XMTOT-PPBLOB(4)
13905 * Lorentz-transformation back into system of initial diff. collision
13906 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13907 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13908 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13909 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13910 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13911 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13912 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13913 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13914 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13916 * store 4-momentum of elastically scattered particle (in single diff.
13922 ELSEIF (KT.EQ.0) THEN
13928 * check consistency of kinematical treatment so far
13930 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13931 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13932 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13933 IF (IREJ1.NE.0) GOTO 9999
13936 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13937 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13939 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13940 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13941 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13942 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
13943 WRITE(LOUT,1003) DEV1,DEV2
13944 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
13949 * kinematical treatment for low-mass diffraction
13950 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13951 IF (IREJ1.NE.0) GOTO 9999
13953 * dump diffractive chains into DTEVT1
13954 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13955 IF (IREJ1.NE.0) GOTO 9999
13960 IRDIFF(1) = IRDIFF(1)+1
13965 *===xmhmd==============================================================*
13967 CDECK ID>, DT_XMHMD
13968 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13970 ************************************************************************
13971 * Diffractive mass in high mass single/double diffractive events. *
13972 * This version dated 11.02.95 is written by S. Roesler *
13973 ************************************************************************
13975 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13978 PARAMETER ( LINP = 5 ,
13982 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13984 * kinematics of diffractive interactions (DTUNUC 1.x)
13985 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13987 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13988 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13990 C DATA XCOLOW /0.05D0/
13991 DATA XCOLOW /0.15D0/
13995 IF (MODE.EQ.2) XH = XTH(2)
13997 * minimum Pomeron-x for high-mass diffraction
13998 * (adjusted to get a smooth transition between HM and LM component)
14000 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14001 IF (ECM.LE.300.0D0) THEN
14002 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14003 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14005 * maximum Pomeron-x for high-mass diffraction
14006 * (coherence condition, adjusted to fit to experimental data)
14008 * baryon-diffraction
14009 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14011 * meson-diffraction
14012 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14015 IF (XDIMIN.GE.XDIMAX) THEN
14016 XDIMIN = OHALF*XDIMAX
14022 IF (KLOOP.GT.20) RETURN
14023 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
14024 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14025 * corr. diffr. mass
14026 DT_XMHMD = ECM*SQRT(XDIFF)
14027 IF (DT_XMHMD.LT.2.5D0) GOTO 1
14032 *===xmlmd==============================================================*
14034 CDECK ID>, DT_XMLMD
14035 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14037 ************************************************************************
14038 * Diffractive mass in high mass single/double diffractive events. *
14039 * This version dated 11.02.95 is written by S. Roesler *
14040 ************************************************************************
14042 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14045 PARAMETER ( LINP = 5 ,
14049 * minimum Pomeron-x for low-mass diffraction
14052 * maximum Pomeron-x for low-mass diffraction
14053 * (adjusted to get a smooth transition between HM and LM component)
14056 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14057 R = DT_RNDM(AMO)*SAM
14058 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14059 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14061 * selection of diffractive mass
14062 * (adjusted to get a smooth transition between HM and LM component)
14064 IF (ECM.LE.50.0D0) THEN
14065 DT_XMLMD = AMO*(AMU/AMO)**R
14068 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14069 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14075 *===tdiff==============================================================*
14077 CDECK ID>, DT_TDIFF
14078 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14080 ************************************************************************
14081 * t-selection for single/double diffractive interactions. *
14083 * TMIN minimum momentum transfer to produce diff. masses *
14084 * XM1/XM2 diffractively produced masses *
14085 * (for single diffraction XM2 is obsolete) *
14086 * K1/K2= 0 not excited *
14087 * = 1 low-mass excitation *
14088 * = 2 high-mass excitation *
14089 * This version dated 11.02.95 is written by S. Roesler *
14090 ************************************************************************
14092 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14095 PARAMETER ( LINP = 5 ,
14099 PARAMETER (ZERO=0.0D0)
14101 PARAMETER ( BTP0 = 3.7D0,
14102 & ALPHAP = 0.24D0 )
14115 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14116 * slope for single diffraction
14117 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14119 * slope for double diffraction
14120 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14125 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14127 T = -LOG(1.0D0-Y)/SLOPE
14128 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14134 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14135 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14136 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14137 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14142 *===xvalhm=============================================================*
14144 CDECK ID>, DT_XVALHM
14145 SUBROUTINE DT_XVALHM(KP,KT)
14147 ************************************************************************
14148 * Sampling of parton x-values in high-mass diffractive interactions. *
14149 * This version dated 12.02.95 is written by S. Roesler *
14150 ************************************************************************
14152 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14155 PARAMETER ( LINP = 5 ,
14159 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14161 * kinematics of diffractive interactions (DTUNUC 1.x)
14162 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14164 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14165 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14166 * various options for treatment of partons (DTUNUC 1.x)
14167 * (chain recombination, Cronin,..)
14168 LOGICAL LCO2CR,LINTPT
14169 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14172 DATA UNON,XVQTHR /2.0D0,0.8D0/
14175 * x-fractions of projectile valence partons
14177 XPH(1) = DT_DBETAR(OHALF,UNON)
14178 IF (XPH(1).GE.XVQTHR) GOTO 1
14179 XPH(2) = ONE-XPH(1)
14180 * x-fractions of Pomeron q-aq-pair
14183 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14184 XPPO(2) = ONE-XPPO(1)
14185 * flavors of Pomeron q-aq-pair
14186 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14189 IF (DT_RNDM(UNON).GT.OHALF) THEN
14196 * x-fractions of projectile target partons
14198 XTH(1) = DT_DBETAR(OHALF,UNON)
14199 IF (XTH(1).GE.XVQTHR) GOTO 2
14200 XTH(2) = ONE-XTH(1)
14201 * x-fractions of Pomeron q-aq-pair
14204 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14205 XTPO(2) = ONE-XTPO(1)
14206 * flavors of Pomeron q-aq-pair
14207 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14210 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14219 *===lm2res=============================================================*
14221 CDECK ID>, DT_LM2RES
14222 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14224 ************************************************************************
14225 * Check low-mass diffractive excitation for resonance mass. *
14226 * (input) IF1/2 PDG-indizes of valence partons *
14227 * (in/out) XM diffractive mass requested/corrected *
14228 * (output) IDR/IDXR id./BAMJET-index of resonance *
14229 * This version dated 12.02.95 is written by S. Roesler *
14230 ************************************************************************
14232 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14235 PARAMETER ( LINP = 5 ,
14239 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14241 * kinematics of diffractive interactions (DTUNUC 1.x)
14242 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14244 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14245 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14252 * BAMJET indices of partons
14253 IF1A = IDT_IPDG2B(IF1,1,2)
14254 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14255 IF2A = IDT_IPDG2B(IF2,1,2)
14256 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14258 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14260 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14262 * check for resonance mass
14263 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14264 IF (IREJ1.NE.0) GOTO 9999
14274 *===lmkine=============================================================*
14276 CDECK ID>, DT_LMKINE
14277 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14279 ************************************************************************
14280 * Kinematical treatment of low-mass excitations. *
14281 * This version dated 12.02.95 is written by S. Roesler *
14282 ************************************************************************
14284 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14287 PARAMETER ( LINP = 5 ,
14291 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14293 * flags for input different options
14294 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14295 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14296 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14297 * kinematics of diffractive interactions (DTUNUC 1.x)
14298 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14300 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14301 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14303 DIMENSION P1(4),P2(4)
14308 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14310 FAC1 = OHALF*(POE+ONE)
14311 FAC2 = -OHALF*(POE-ONE)
14313 PPLM1(K) = FAC1*PPF(K)
14314 PPLM2(K) = FAC2*PPF(K)
14316 PPLM1(4) = FAC1*PABS
14317 PPLM2(4) = -FAC2*PABS
14318 IF (IMSHL.EQ.1) THEN
14323 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14324 IF (IREJ1.NE.0) GOTO 9999
14333 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14335 FAC1 = OHALF*(POE+ONE)
14336 FAC2 = -OHALF*(POE-ONE)
14338 PTLM2(K) = FAC1*PTF(K)
14339 PTLM1(K) = FAC2*PTF(K)
14341 PTLM2(4) = FAC1*PABS
14342 PTLM1(4) = -FAC2*PABS
14343 IF (IMSHL.EQ.1) THEN
14348 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14349 IF (IREJ1.NE.0) GOTO 9999
14360 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14365 *===difini=============================================================*
14367 CDECK ID>, DT_DIFINI
14368 SUBROUTINE DT_DIFINI
14370 ************************************************************************
14371 * Initialization of common /DTDIKI/ *
14372 * This version dated 12.02.95 is written by S. Roesler *
14373 ************************************************************************
14375 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14378 PARAMETER ( LINP = 5 ,
14382 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14384 * kinematics of diffractive interactions (DTUNUC 1.x)
14385 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14387 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14388 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14416 *===difput=============================================================*
14418 CDECK ID>, DT_DIFPUT
14419 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14422 ************************************************************************
14423 * Dump diffractive chains into DTEVT1 *
14424 * This version dated 12.02.95 is written by S. Roesler *
14425 ************************************************************************
14427 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14430 PARAMETER ( LINP = 5 ,
14434 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14438 * kinematics of diffractive interactions (DTUNUC 1.x)
14439 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14441 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14442 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14445 PARAMETER (NMXHKK=200000)
14447 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14448 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14449 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14450 * extended event history
14451 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14452 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14454 * rejection counter
14455 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14456 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14457 & IREXCI(3),IRDIFF(2),IRINC
14459 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14460 & P1(4),P2(4),P3(4),P4(4)
14466 PCH(K) = PPLM1(K)+PPLM2(K)
14470 IF (DT_RNDM(PT).GT.OHALF) THEN
14474 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14476 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14478 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14480 ELSEIF (KP.EQ.2) THEN
14482 PP1(K) = XPH(1)*PP(K)
14483 PP2(K) = XPH(2)*PP(K)
14484 PT1(K) = -XPPO(1)*PPOM(K)
14485 PT2(K) = -XPPO(2)*PPOM(K)
14487 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14491 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14492 IF (IREJ1.NE.0) GOTO 9999
14493 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14494 IF (IREJ1.NE.0) GOTO 9999
14501 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14503 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14505 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14507 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14510 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14511 IF (IREJ1.NE.0) GOTO 9999
14512 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14513 IF (IREJ1.NE.0) GOTO 9999
14520 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14522 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14524 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14526 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14531 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14537 PCH(K) = PTLM1(K)+PTLM2(K)
14541 IF (DT_RNDM(PT).GT.OHALF) THEN
14545 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14547 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14549 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14551 ELSEIF (KT.EQ.2) THEN
14553 PP1(K) = XTPO(1)*PPOM(K)
14554 PP2(K) = XTPO(2)*PPOM(K)
14555 PT1(K) = XTH(2)*PT(K)
14556 PT2(K) = XTH(1)*PT(K)
14558 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14562 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14563 IF (IREJ1.NE.0) GOTO 9999
14564 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14565 IF (IREJ1.NE.0) GOTO 9999
14572 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14574 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14576 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14578 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14581 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14582 IF (IREJ1.NE.0) GOTO 9999
14583 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14584 IF (IREJ1.NE.0) GOTO 9999
14591 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14593 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14595 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14597 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14602 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14609 IRDIFF(2) = IRDIFF(2)+1
14614 *===evtfrg=============================================================*
14616 CDECK ID>, DT_EVTFRG
14617 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14619 ************************************************************************
14620 * Hadronization of chains in DTEVT1. *
14623 * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
14624 * = 2 hadronization of DTUNUC-chains (id=88xxx) *
14625 * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
14626 * hadronized with one PYEXEC call *
14627 * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14628 * with one PYEXEC call *
14630 * NPYMEM number of entries in JETSET-common after hadronization *
14631 * IREJ rejection flag *
14633 * This version dated 17.09.00 is written by S. Roesler *
14634 ************************************************************************
14636 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14639 PARAMETER ( LINP = 5 ,
14643 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14644 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14648 PARAMETER (MXJOIN=200)
14652 PARAMETER (NMXHKK=200000)
14654 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14655 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14656 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14657 * extended event history
14658 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14659 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14661 * flags for input different options
14662 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14663 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14664 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14666 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14667 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14669 * flags for diffractive interactions (DTUNUC 1.x)
14670 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14671 * nucleon-nucleon event-generator
14674 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14676 C model switches and parameters
14678 INTEGER ISWMDL,IPAMDL
14679 DOUBLE PRECISION PARMDL
14680 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14683 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14685 PARAMETER (MAXLND=4000)
14686 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14690 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14694 IF (MODE.NE.1) ISTSTG = 8
14703 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14704 DO 10 I=NPOINT(3),NEND
14705 * sr 14.02.00: seems to be not necessary anymore, commented
14706 C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14707 C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14709 * pick up chains from dtevt1
14710 IDCHK = IDHKK(I)/10000
14711 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14712 IF (IDCHK.EQ.7) THEN
14713 IPJE = IDHKK(I)-IDCHK*10000
14714 IF (IPJE.NE.IFRG) THEN
14716 IF (IFRG.GT.NFRG) GOTO 16
14721 IF (IFRG.GT.NFRG) THEN
14726 * statistics counter
14727 c IF (IDCH(I).LE.8)
14728 c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14729 c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14730 * special treatment for small chains already corrected to hadrons
14731 IF (IDRES(I).NE.0) THEN
14732 IF (IDRES(I).EQ.11) THEN
14735 ID = IDT_IPDGHA(IDXRES(I))
14738 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14739 & PHKK(4,I),INIEMC,IDUM,IDUM)
14743 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14744 P(IP,1) = PHKK(1,I)
14745 P(IP,2) = PHKK(2,I)
14746 P(IP,3) = PHKK(3,I)
14747 P(IP,4) = PHKK(4,I)
14748 P(IP,5) = PHKK(5,I)
14754 IHIST(2,I) = 10000*IPJE+IP
14755 IF (IHIST(1,I).LE.-100) THEN
14757 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14764 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14766 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14767 & PHKK(4,KK),INIEMC,IDUM,IDUM)
14768 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14772 IF (ID.EQ.0) ID = 21
14773 c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14774 c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14776 c AMRQ = PYMASS(ID)
14778 c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14779 c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14780 c & (ABS(IDIFF).EQ.0)) THEN
14781 cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14782 c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14783 c PHKK(4,KK) = PHKK(4,KK)+DELTA
14784 c PTOT1 = PTOT-DELTA
14785 c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14786 c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14787 c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14788 c PHKK(5,KK) = AMRQ
14791 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14792 P(IP,1) = PHKK(1,KK)
14793 P(IP,2) = PHKK(2,KK)
14794 P(IP,3) = PHKK(3,KK)
14795 P(IP,4) = PHKK(4,KK)
14796 P(IP,5) = PHKK(5,KK)
14802 IHIST(2,KK) = 10000*IPJE+IP
14803 IF (IHIST(1,KK).LE.-100) THEN
14805 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14809 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14814 * join the two-parton system
14816 CALL PYJOIN(IJ,IJOIN)
14827 * final state parton shower
14829 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14830 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14832 IF (ISJOIN(K1).EQ.0) GOTO 130
14834 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14836 IH1 = IHIST(2,I)/10000
14837 IF (IH1.NE.NPJE) GOTO 130
14838 IH1 = IHIST(2,I)-IH1*10000
14840 IF (ISJOIN(K2).EQ.0) GOTO 135
14842 IH2 = IHIST(2,II)/10000
14843 IF (IH2.NE.NPJE) GOTO 135
14844 IH2 = IHIST(2,II)-IH2*10000
14845 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14846 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14847 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14849 RQLUN = MIN(PT1,PT2)
14850 CALL PYSHOW(IH1,IH2,RQLUN)
14862 CALL DT_INITJS(MODE)
14867 IF (MSTU(24).NE.0) THEN
14868 WRITE(LOUT,*) ' JETSET-reject at event',
14869 & NEVHKK,MSTU(24),KMODE
14870 C CALL DT_EVTOUT(4)
14877 * number of entries in LUJETS
14889 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14891 * pick up mother resonance if possible and put it together with
14892 * their decay-products into the common
14894 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14895 KFMOR = K(IDXMOR,2)
14896 ISMOR = K(IDXMOR,1)
14901 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14902 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14905 MO = IHISMO(PYK(IDXMOR,15))
14911 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14914 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14916 IF (PYK(JDAUG,7).EQ.1) THEN
14923 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14931 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14937 * there was no mother resonance
14939 MO = IHISMO(PYK(II,15))
14946 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14954 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14961 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14962 C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14965 * global energy-momentum & flavor conservation check
14966 **sr 16.5. this check is skipped in case of phojet-treatment
14968 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14970 * update statistics-counter for diffraction
14971 c IF (IFLAGD.NE.0) THEN
14972 c ICDIFF(1) = ICDIFF(1)+1
14973 c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14974 c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14975 c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14976 c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14988 *===decay==============================================================*
14990 CDECK ID>, DT_DECAYS
14991 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14993 ************************************************************************
14994 * Resonance-decay. *
14995 * This subroutine replaces DDECAY/DECHKK. *
14996 * PIN(4) 4-momentum of resonance (input) *
14997 * IDXIN BAMJET-index of resonance (input) *
14998 * POUT(20,4) 4-momenta of decay-products (output) *
14999 * IDXOUT(20) BAMJET-indices of decay-products (output) *
15000 * NSEC number of secondaries (output) *
15001 * Adopted from the original version DECHKK. *
15002 * This version dated 09.01.95 is written by S. Roesler *
15003 ************************************************************************
15005 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15008 PARAMETER ( LINP = 5 ,
15012 PARAMETER (TINY17=1.0D-17)
15014 * HADRIN: decay channel information
15015 PARAMETER (IDMAX9=602)
15017 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15018 * particle properties (BAMJET index convention)
15020 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15021 & IICH(210),IIBAR(210),K1(210),K2(210)
15022 * flags for input different options
15023 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15024 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15025 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15027 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15028 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15029 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15031 * ISTAB = 1 strong and weak decays
15032 * = 2 strong decays only
15033 * = 3 strong decays, weak decays for charmed particles and tau
15039 * put initial resonance to stack
15041 IDXSTK(NSTK) = IDXIN
15043 PI(NSTK,I) = PIN(I)
15046 * store initial configuration for energy-momentum cons. check
15047 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15048 & PI(NSTK,4),1,IDUM,IDUM)
15051 * get particle from stack
15052 IDXI = IDXSTK(NSTK)
15053 * skip stable particles
15054 IF (ISTAB.EQ.1) THEN
15055 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15056 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
15057 ELSEIF (ISTAB.EQ.2) THEN
15058 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
15059 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15060 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15061 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15062 IF ( IDXI.EQ.109) GOTO 10
15063 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15064 ELSEIF (ISTAB.EQ.3) THEN
15065 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
15066 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15067 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15068 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15071 * calculate direction cosines and Lorentz-parameter of decaying part.
15072 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15073 PTOT = MAX(PTOT,TINY17)
15075 DCOS(I) = PI(NSTK,I)/PTOT
15077 GAM = PI(NSTK,4)/AAM(IDXI)
15078 BGAM = PTOT/AAM(IDXI)
15080 * get decay-channel
15084 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15086 * identities of secondaries
15087 IDX(1) = NZK(KCHAN,1)
15088 IDX(2) = NZK(KCHAN,2)
15089 IF (IDX(2).LT.1) GOTO 9999
15090 IDX(3) = NZK(KCHAN,3)
15092 * handle decay in rest system of decaying particle
15093 IF (IDX(3).EQ.0) THEN
15094 * two-particle decay
15096 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15097 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15098 & AAM(IDX(1)),AAM(IDX(2)))
15100 * three-particle decay
15102 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15103 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15104 & CODF(3),COFF(3),SIFF(3),
15105 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15109 * transform decay products back
15112 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15113 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15114 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15115 * add particle to stack
15116 IDXSTK(NSTK) = IDX(I)
15118 PI(NSTK,J) = DCOSF(J)*PFF(I)
15124 * stable particle, put to output-arrays
15127 POUT(NSEC,I) = PI(NSTK,I)
15129 IDXOUT(NSEC) = IDXSTK(NSTK)
15130 * store secondaries for energy-momentum conservation check
15132 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15133 & -POUT(NSEC,4),2,IDUM,IDUM)
15135 IF (NSTK.GT.0) GOTO 100
15137 * check energy-momentum conservation
15139 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15140 IF (IREJ1.NE.0) GOTO 9999
15150 *===decay1=============================================================*
15152 CDECK ID>, DT_DECAY1
15153 SUBROUTINE DT_DECAY1
15155 ************************************************************************
15156 * Decay of resonances stored in DTEVT1. *
15157 * This version dated 20.01.95 is written by S. Roesler *
15158 ************************************************************************
15160 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15163 PARAMETER ( LINP = 5 ,
15169 PARAMETER (NMXHKK=200000)
15171 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15172 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15173 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15174 * extended event history
15175 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15176 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15179 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15182 C DO 1 I=NPOINT(5),NEND
15183 DO 1 I=NPOINT(4),NEND
15184 IF (ABS(ISTHKK(I)).EQ.1) THEN
15189 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15190 IF (NSEC.GT.1) THEN
15192 IDHAD = IDT_IPDGHA(IDXOUT(N))
15193 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15194 & POUT(N,3),POUT(N,4),0,0,0)
15203 *===decpi0=============================================================*
15205 CDECK ID>, DT_DECPI0
15206 SUBROUTINE DT_DECPI0
15208 ************************************************************************
15209 * Decay of pi0 handled with JETSET. *
15210 * This version dated 18.02.96 is written by S. Roesler *
15211 ************************************************************************
15213 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15216 PARAMETER ( LINP = 5 ,
15220 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15224 PARAMETER (NMXHKK=200000)
15226 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15227 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15228 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15229 * extended event history
15230 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15231 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15234 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15236 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15238 PARAMETER (MAXLND=4000)
15239 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15241 * flags for input different options
15242 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15243 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15244 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15248 DIMENSION IHISMO(NMXHKK),P1(4)
15250 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15262 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15268 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15269 & PHKK(4,I),INI,IDUM,IDUM)
15270 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15271 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15272 COSTH = PHKK(3,I)/(PTOT+TINY10)
15273 IF (COSTH.GT.ONE) THEN
15275 ELSEIF (COSTH.LT.-ONE) THEN
15276 THETA = TWOPI/2.0D0
15278 THETA = ACOS(COSTH)
15280 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15281 IF (PHKK(1,I).LT.0.0D0)
15283 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15289 P(NN,5) = PHKK(5,I)
15291 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15305 IF (PYK(II,7).EQ.1) THEN
15309 P1(KK) = PYP(II,KK)
15314 MO = IHISMO(PYK(II,15))
15316 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15318 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15320 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15324 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15331 *===dtwopd=============================================================*
15333 CDECK ID>, DT_DTWOPD
15334 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15335 & COF2,SIF2,AM1,AM2)
15337 ************************************************************************
15338 * Two-particle decay. *
15339 * UMO cm-energy of the decaying system (input) *
15340 * AM1/AM2 masses of the decay products (input) *
15341 * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15342 * COD,COF,SIF direction cosines of the decay prod. (output) *
15343 * Revised by S. Roesler, 20.11.95 *
15344 ************************************************************************
15346 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15349 PARAMETER ( LINP = 5 ,
15353 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15355 IF (UMO.LT.(AM1+AM2)) THEN
15356 WRITE(LOUT,1000) UMO,AM1,AM2
15357 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15362 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15364 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15366 CALL DT_DSFECF(SIF1,COF1)
15367 COD1 = TWO*DT_RNDM(PCM2)-ONE
15375 *===dthrep=============================================================*
15377 CDECK ID>, DT_DTHREP
15378 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15379 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15381 ************************************************************************
15382 * Three-particle decay. *
15383 * UMO cm-energy of the decaying system (input) *
15384 * AM1/2/3 masses of the decay products (input) *
15385 * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15386 * COD,COF,SIF direction cosines of the decay prod. (output) *
15388 * Threpd89: slight revision by A. Ferrari *
15389 * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15390 * Revised by S. Roesler, 20.11.95 *
15391 ************************************************************************
15393 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15396 PARAMETER ( LINP = 5 ,
15400 PARAMETER ( ANGLSQ = 2.5D-31 )
15401 PARAMETER ( AZRZRZ = 1.0D-30 )
15402 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15403 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15404 PARAMETER ( ONEONE = 1.D+00 )
15405 PARAMETER ( TWOTWO = 2.D+00 )
15406 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15408 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15409 * flags for input different options
15410 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15411 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15412 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15414 DIMENSION F(5),XX(5)
15418 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15419 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15420 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15427 * UFAK=1.0000000000001D0
15428 * IF (GU.GT.GO) UFAK=0.9999999999999D0
15446 S22=GU+(I-1.D0)*DS2
15448 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15450 IF(RHO2.LT.RHO1) GO TO 125
15452 125 S2SUP=(S22-S21)*.5D0+S21
15453 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15455 SUPRHO=SUPRHO*1.05D0
15457 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15458 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15464 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15465 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15467 X4=(XX(1)+XX(2))*0.5D0
15468 X5=(XX(2)+XX(3))*0.5D0
15469 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15471 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15478 IF (F (II).GE.F (III)) GO TO 128
15491 IF (XX(II).GE.XX(III)) GO TO 129
15505 IF (ITH.GT.200) REDU=-9.D0
15506 IF (ITH.GT.200) GO TO 400
15508 * S2=AM23+C*((UMO-AM1)**2-AM23)
15509 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15512 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15513 IF(Y.GT.RHO) GO TO 1
15514 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15516 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15518 S3=UMO2+AM11+AM22+AM33-S1-S2
15519 ECM1=(UMO2+AM11-S2)/UMOO
15520 ECM2=(UMO2+AM22-S3)/UMOO
15521 ECM3=(UMO2+AM33-S1)/UMOO
15522 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15523 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15524 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15525 CALL DT_DSFECF(SFE,CFE)
15526 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15527 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15528 PCM12 = PCM1 * PCM2
15529 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15530 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15534 COSTH=(UW-0.5D+00)*2.D+00
15536 * IF(ABS(COSTH).GT.0.9999999999999999D0)
15537 * &COSTH=SIGN(0.9999999999999999D0,COSTH)
15538 IF(ABS(COSTH).GT.ONEONE)
15539 &COSTH=SIGN(ONEONE,COSTH)
15540 IF (REDU.LT.1.D+00) RETURN
15541 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15542 * IF(ABS(COSTH2).GT.0.9999999999999999D0)
15543 * &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15544 IF(ABS(COSTH2).GT.ONEONE)
15545 &COSTH2=SIGN(ONEONE,COSTH2)
15546 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15547 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15548 SINTH1=COSTH2*SINTH-COSTH*SINTH2
15549 COSTH1=COSTH*COSTH2+SINTH2*SINTH
15550 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15551 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15552 C***THE DIRECTION OF PARTICLE 3
15553 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15560 CALL DT_DSFECF(SIF3,COF3)
15561 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15562 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15564 COD1=CX11*COD3+CZ11*SID3
15565 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15566 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15569 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15570 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15571 COD2=CX22*COD3+CZ22*SID3
15572 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15573 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15574 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15576 * === Energy conservation check: === *
15577 EOCHCK = UMO - ECM1 - ECM2 - ECM3
15578 * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15579 * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15580 * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15581 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15582 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15583 & + PCM3 * COF3 * SID3
15584 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15585 & + PCM3 * SIF3 * SID3
15586 EOCMPR = 1.D-12 * UMO
15587 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15588 & .GT. EOCMPR ) THEN
15589 **sr 5.5.95 output-unit changed
15590 IF (IOULEV(1).GT.0) THEN
15592 & ' *** Threpd: energy/momentum conservation failure! ***',
15593 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
15594 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15601 *===dbklas=============================================================*
15603 CDECK ID>, DT_DBKLAS
15604 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15606 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15609 PARAMETER ( LINP = 5 ,
15613 * quark-content to particle index conversion (DTUNUC 1.x)
15614 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15615 & IA08(6,21),IA10(6,21)
15620 CALL DT_INDEXD(J,K,IND)
15623 IF (I8.LE.0) I8 = I10
15630 CALL DT_INDEXD(JJ,KK,IND)
15633 IF (I8.LE.0) I8 = I10
15638 *===indexd=============================================================*
15640 CDECK ID>, DT_INDEXD
15641 SUBROUTINE DT_INDEXD(KA,KB,IND)
15643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15646 PARAMETER ( LINP = 5 ,
15655 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15657 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15658 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15659 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15661 IF (KP.EQ.10) IND=10
15662 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15663 IF (KP.EQ.9) IND=12
15664 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15665 IF (KP.EQ.15) IND=14
15666 IF (KP.EQ.18) IND=15
15667 IF (KP.EQ.16) IND=16
15668 IF (KP.EQ.20) IND=17
15669 IF (KP.EQ.24) IND=18
15670 IF (KP.EQ.25) IND=19
15671 IF (KP.EQ.30) IND=20
15672 IF (KP.EQ.36) IND=21
15677 *===dchant=============================================================*
15679 CDECK ID>, DT_DCHANT
15680 SUBROUTINE DT_DCHANT
15682 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15685 PARAMETER ( LINP = 5 ,
15689 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15691 * HADRIN: decay channel information
15692 PARAMETER (IDMAX9=602)
15694 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15695 * particle properties (BAMJET index convention)
15697 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15698 & IICH(210),IIBAR(210),K1(210),K2(210)
15700 DIMENSION HWT(IDMAX9)
15702 * change of weights wt from absolut values into the sum of wt of a dec.
15707 C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15708 C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15709 C & K1(KKK),K2(KKK)
15720 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15721 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15731 *===ddatar=============================================================*
15733 CDECK ID>, DT_DDATAR
15734 SUBROUTINE DT_DDATAR
15736 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15739 PARAMETER ( LINP = 5 ,
15743 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15745 * quark-content to particle index conversion (DTUNUC 1.x)
15746 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15747 & IA08(6,21),IA10(6,21)
15749 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15751 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
15752 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
15754 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
15755 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
15757 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
15758 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
15759 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
15760 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
15761 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
15762 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
15763 & 0, 0, 0,140,137,138,146, 0, 0,142,
15764 & 139,147, 0, 0,145,148, 50*0/
15765 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
15766 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
15767 & 0, 54, 55,105,162, 0, 0, 56,106,163,
15768 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
15769 & 0, 0,104,105,107,164, 0, 0,106,108,
15770 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
15771 & 0, 0, 0,161,162,164,167, 0, 0,163,
15772 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
15773 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
15774 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
15775 & 0, 2, 9,100,149, 0, 0, 0,101,154,
15776 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
15777 & 0, 0, 99,100,102,150, 0, 0,101,103,
15778 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
15779 & 0, 0, 0,152,149,150,158, 0, 0,154,
15780 & 151,159, 0, 0,157,160, 50*0/
15781 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
15782 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
15783 & 0, 68, 69,111,172, 0, 0, 70,112,173,
15784 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
15785 & 0, 0,110,111,113,174, 0, 0,112,114,
15786 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
15787 & 0, 0, 0,171,172,174,177, 0, 0,173,
15788 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
15824 *===initjs=============================================================*
15826 CDECK ID>, DT_INITJS
15827 SUBROUTINE DT_INITJS(MODE)
15829 ************************************************************************
15830 * Initialize JETSET paramters. *
15831 * MODE = 0 default settings *
15832 * = 1 PHOJET settings *
15833 * = 2 DTUNUC settings *
15834 * This version dated 16.02.96 is written by S. Roesler *
15835 ************************************************************************
15837 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15840 PARAMETER ( LINP = 5 ,
15844 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15846 LOGICAL LFIRST,LFIRDT,LFIRPH
15851 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15853 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15855 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15857 * flags for particle decays
15858 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15859 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15860 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15861 * flags for input different options
15862 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15863 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15864 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15868 DIMENSION IDXSTA(40)
15870 * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
15871 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15872 * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
15873 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
15874 * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15875 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15876 * Ksic0 aKsic+aKsic0 sig0 asig0
15877 & 4132,-4232,-4132, 3212,-3212, 5*0/
15879 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15882 * save default settings
15894 * LUJETS / PYJETS array-dimensions
15898 * increase maximum number of JETSET-error prints
15900 * prevent particles decaying
15904 KC = PYCOMP(IDXSTA(I))
15911 C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15912 C & (I.EQ.8).OR.(I.EQ.10)) THEN
15913 C ELSEIF (I.EQ.4) THEN
15919 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15921 KC = PYCOMP(IDXSTA(I))
15928 * as Fluka event-generator: allow only paprop particles to be stable
15929 * and let all other particles decay (i.e. those with strong decays)
15930 IF (ITRSPT.EQ.1) THEN
15932 IF (KPTOIP(I).NE.0) THEN
15937 IF (MDCY(KC,1).EQ.1) THEN
15938 WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
15939 & 'transport : particle should not ',
15940 & 'decay : ',IDPDG,' ',ANAME(I)
15949 IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
15950 & (ANAME(KP).NE.'BLANK ').AND.
15951 & (ANAME(KP).NE.'RNDFLV ')) THEN
15952 WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
15953 & 'transport: particle should decay ',
15954 & ': ',IDPDG,' ',ANAME(KP)
15963 IF (PDB.LE.ZERO) THEN
15964 * no popcorn-mechanism
15970 * set JETSET-parameter requested by input cards
15971 IF (NMSTU.GT.0) THEN
15973 MSTU(IMSTU(I)) = MSTUX(I)
15976 IF (NMSTJ.GT.0) THEN
15978 MSTJ(IMSTJ(I)) = MSTJX(I)
15981 IF (NPARU.GT.0) THEN
15983 PARU(IPARU(I)) = PARUX(I)
15989 * PARJ(1) suppression of qq-aqaq pair prod. compared to
15990 * q-aq pair prod. (default: 0.1)
15991 * PARJ(2) strangeness suppression (default: 0.3)
15992 * PARJ(3) extra suppression of strange diquarks (default: 0.4)
15993 * PARJ(6) extra suppression of sas-pair shared by B and
15994 * aB in BMaB (default: 0.5)
15995 * PARJ(7) extra suppression of strange meson M in BMaB
15996 * configuration (default: 0.5)
15997 * PARJ(18) spin 3/2 baryon suppression (default: 1.0)
15998 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15999 * momentum distrib. for prim. hadrons (default: 0.35)
16000 * PARJ(42) b-parameter for symmetric Lund-fragmentation
16001 * function (default: 0.9 GeV^-2)
16004 IF (MODE.EQ.1) THEN
16011 C PARJ(18) = PDEF18
16012 C PARJ(21) = PDEF21
16013 C PARJ(42) = PDEF42
16014 **sr 18.11.98 parameter tuning
16015 C PARJ(1) = 0.092D0
16019 C PARJ(21) = 0.45D0
16021 **sr 28.04.99 parameter tuning (May 99 minor modifications)
16031 IF (NPARJ.GT.0) THEN
16033 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16037 C *** Commented by Chiara
16038 C WRITE(LOUT,'(1X,A)')
16039 C & 'DT_INITJS: JETSET-parameter for PHOJET'
16044 ELSEIF (MODE.EQ.2) THEN
16045 IF (IFRAG(2).EQ.1) THEN
16046 **sr parameters before 9.3.96
16051 C PARJ(21) = 0.55D0
16053 **sr 18.11.98 parameter tuning
16058 C PARJ(21) = 0.45D0
16060 **sr 28.04.99 parameter tuning
16068 IF (NPARJ.GT.0) THEN
16070 IF (IPARJ(I).LT.0) THEN
16071 IDX = ABS(IPARJ(I))
16072 PARJ(IDX) = PARJX(I)
16077 WRITE(LOUT,'(1X,A)')
16078 & 'DT_INITJS: JETSET-parameter for DTUNUC'
16082 ELSEIF (IFRAG(2).EQ.2) THEN
16089 C PARJ(21) = 0.55D0
16120 *===jspara=============================================================*
16122 CDECK ID>, DT_JSPARA
16123 SUBROUTINE DT_JSPARA(MODE)
16125 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16128 PARAMETER ( LINP = 5 ,
16132 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16133 & ONE=1.0D0,ZERO=0.0D0)
16137 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16139 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16141 DATA LFIRST /.TRUE./
16143 * save the default JETSET-parameter on the first call
16154 C *** Commented by Chiara
16156 C 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16158 * compare the default JETSET-parameter with the present values
16160 C *** Commented by Chiara
16161 C IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16162 C WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16163 CC ISTU(I) = MSTU(I)
16165 DIFF = ABS(PARU(I)-QARU(I))
16166 C *** Commented by Chiara
16167 C IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16168 C WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16169 CC QARU(I) = PARU(I)
16171 C *** Commented by Chiara
16172 C IF (MSTJ(I).NE.ISTJ(I)) THEN
16173 C WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16174 CC ISTJ(I) = MSTJ(I)
16176 DIFF = ABS(PARJ(I)-QARJ(I))
16177 C *** Commented by Chiara
16178 C IF (DIFF.GE.1.0D-5) THEN
16179 C WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16180 CC QARJ(I) = PARJ(I)
16183 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16184 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16189 *===fozoca=============================================================*
16191 CDECK ID>, DT_FOZOCA
16192 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16194 ************************************************************************
16195 * This subroutine treats the complete FOrmation ZOne supressed intra- *
16196 * nuclear CAscade. *
16197 * LFZC = .true. cascade has been treated *
16198 * = .false. cascade skipped *
16199 * This is a completely revised version of the original FOZOKL. *
16200 * This version dated 18.11.95 is written by S. Roesler *
16201 ************************************************************************
16203 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16206 PARAMETER ( LINP = 5 ,
16210 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16211 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16213 LOGICAL LSTART,LCAS,LFZC
16217 PARAMETER (NMXHKK=200000)
16219 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16220 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16221 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16222 * extended event history
16223 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16224 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16226 * rejection counter
16227 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16228 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16229 & IREXCI(3),IRDIFF(2),IRINC
16230 * properties of interacting particles
16231 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16232 * Glauber formalism: collision properties
16233 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16234 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16235 * flags for input different options
16236 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16237 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16238 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16239 * final state after intranuclear cascade step
16240 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16241 * parameter for intranuclear cascade
16243 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16245 DIMENSION NCWOUN(2)
16247 DATA LSTART /.TRUE./
16252 * skip cascade if hadron-hadron interaction or if supressed by user
16253 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16254 * skip cascade if not all possible chains systems are hadronized
16256 IF (.NOT.LHADRO(I)) GOTO 9999
16260 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16261 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16262 & 'maximum of',I4,' generations',/,10X,'formation time ',
16263 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16264 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16265 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16266 1001 FORMAT(10X,'p_t dependent formation zone',/)
16267 1002 FORMAT(10X,'constant formation zone',/)
16271 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16272 * which may interact with final state particles are stored in a seperate
16273 * array - here all proj./target nucleon-indices (just for simplicity)
16275 DO 9 I=1,NPOINT(1)-1
16280 * initialize Pauli-principle treatment (find wounded nucleons)
16287 IF (ISTHKK(J).EQ.10+I) THEN
16288 NWOUND(I) = NWOUND(I)+1
16289 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16290 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16295 * modify nuclear potential for wounded nucleons
16296 IPRCL = IP -NWOUND(1)
16297 IPZRCL = IPZ-NCWOUN(1)
16298 ITRCL = IT -NWOUND(2)
16299 ITZRCL = ITZ-NCWOUN(2)
16300 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16308 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16309 * select nucleus the cascade starts first (proj. - 1, target - -1)
16311 * projectile/target with probab. 1/2
16312 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16313 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16314 * in the nucleus with highest mass
16315 ELSEIF (INCMOD.EQ.2) THEN
16318 ELSEIF (IP.EQ.IT) THEN
16319 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16321 * the nucleus the cascade starts first is requested to be the one
16322 * moving in the direction of the secondary
16323 ELSEIF (INCMOD.EQ.3) THEN
16324 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16326 * check that the selected "nucleus" is not a hadron
16327 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16328 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
16330 * treat intranuclear cascade in the nucleus selected first
16332 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16333 IF (IREJ1.NE.0) GOTO 9998
16334 * treat intranuclear cascade in the other nucleus if this isn't a had.
16336 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16337 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
16338 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16339 IF (IREJ1.NE.0) GOTO 9998
16347 IF (NSTART.LE.NEND) GOTO 7
16352 * reject this event
16357 * intranucl. cascade not treated because of interaction properties or
16358 * it is supressed by user or it was rejected or...
16360 * reset flag characterizing direction of motion in n-n-cms
16362 C DO 9990 I=NPOINT(5),NHKK
16363 C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16369 *===inucas=============================================================*
16371 CDECK ID>, DT_INUCAS
16372 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16374 ************************************************************************
16375 * Formation zone supressed IntraNUclear CAScade for one final state *
16377 * IT, IP mass numbers of target, projectile nuclei *
16378 * IDXCAS index of final state particle in DTEVT1 *
16379 * NCAS = 1 intranuclear cascade in projectile *
16380 * = -1 intranuclear cascade in target *
16381 * This version dated 18.11.95 is written by S. Roesler *
16382 ************************************************************************
16384 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16387 PARAMETER ( LINP = 5 ,
16391 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16392 & OHALF=0.5D0,ONE=1.0D0)
16393 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16394 PARAMETER (TWOPI=6.283185307179586454D+00)
16395 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16397 LOGICAL LABSOR,LCAS
16401 PARAMETER (NMXHKK=200000)
16403 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16404 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16405 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16406 * extended event history
16407 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16408 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16410 * final state after inc step
16411 PARAMETER (MAXFSP=10)
16412 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16413 * flags for input different options
16414 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16415 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16416 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16417 * particle properties (BAMJET index convention)
16419 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16420 & IICH(210),IIBAR(210),K1(210),K2(210)
16421 * Glauber formalism: collision properties
16422 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16423 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16424 * nuclear potential
16426 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16427 & EBINDP(2),EBINDN(2),EPOT(2,210),
16428 & ETACOU(2),ICOUL,LFERMI
16429 * parameter for intranuclear cascade
16431 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16432 * final state after intranuclear cascade step
16433 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16434 * nucleon-nucleon event-generator
16437 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16438 * statistics: residual nuclei
16439 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16440 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16441 & NINCST(2,4),NINCEV(2),
16442 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16443 & NRESPB(2),NRESCH(2),NRESEV(4),
16444 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16447 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16448 & PCAS1(5),PNUC(5),BGTA(4),
16449 & BGCAS(2),GACAS(2),BECAS(2),
16450 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16452 DATA PDIF /0.545D0/
16457 IF (NINCEV(1).NE.NEVHKK) THEN
16459 NINCEV(2) = NINCEV(2)+1
16462 * "BAMJET-index" of this hadron
16463 IDCAS = IDBAM(IDXCAS)
16464 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16466 * skip gammas, electrons, etc..
16467 IF (AAM(IDCAS).LT.TINY2) RETURN
16469 * Lorentz-trsf. into projectile rest system
16471 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16472 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16473 & PCAS(1,4),IDCAS,-2)
16474 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16475 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16476 IF (PCAS(1,5).GT.ZERO) THEN
16477 PCAS(1,5) = SQRT(PCAS(1,5))
16479 PCAS(1,5) = AAM(IDCAS)
16482 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16484 * Lorentz-parameters
16485 * particle rest system --> projectile rest system
16486 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16487 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16488 BECAS(1) = BGCAS(1)/GACAS(1)
16492 IF (K.LE.3) COSCAS(1,K) = ZERO
16499 * Lorentz-trsf. into target rest system
16501 * LEPTO: final state particles are already in target rest frame
16502 C IF (MCGENE.EQ.3) THEN
16503 C PCAS(2,1) = PHKK(1,IDXCAS)
16504 C PCAS(2,2) = PHKK(2,IDXCAS)
16505 C PCAS(2,3) = PHKK(3,IDXCAS)
16506 C PCAS(2,4) = PHKK(4,IDXCAS)
16508 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16509 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16510 & PCAS(2,4),IDCAS,-3)
16512 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16513 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16514 IF (PCAS(2,5).GT.ZERO) THEN
16515 PCAS(2,5) = SQRT(PCAS(2,5))
16517 PCAS(2,5) = AAM(IDCAS)
16520 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16522 * Lorentz-parameters
16523 * particle rest system --> target rest system
16524 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16525 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16526 BECAS(2) = BGCAS(2)/GACAS(2)
16530 IF (K.LE.3) COSCAS(2,K) = ZERO
16538 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16539 * potential (see CONUCL)
16540 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
16541 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
16542 * impact parameter (the projectile moving along z)
16544 BIMPC(2) = BIMPAC*FM2MM
16546 * get position of initial hadron in projectile/target rest-syst.
16548 VTXCAS(1,K) = WHKK(K,IDXCAS)
16549 VTXCAS(2,K) = VHKK(K,IDXCAS)
16554 IF (NCAS.EQ.-1) THEN
16559 IF (PTOCAS(ICAS).LT.TINY10) THEN
16560 WRITE(LOUT,1000) PTOCAS
16561 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
16562 & ' hadron ',/,20X,2E12.4)
16566 * reset spectator flags
16573 * formation length (in fm)
16577 DEL0 = TAUFOR*BGCAS(ICAS)
16578 IF (ITAUVE.EQ.1) THEN
16579 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16580 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16583 * sample from exp(-del/del0)
16584 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16585 * save formation time
16586 TAUSA1 = DEL1/BGCAS(ICAS)
16587 REL1 = TAUSA1*BGCAS(I2)
16590 TAUSAM = DEL/BGCAS(ICAS)
16591 REL = TAUSAM*BGCAS(I2)
16593 * special treatment for negative particles unable to escape
16594 * nuclear potential (implemented for ap, pi-, K- only)
16596 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16597 * threshold energy = nuclear potential + Coulomb potential
16598 * (nuclear potential for hadron-nucleus interactions only)
16599 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16600 IF (PCAS(ICAS,4).LT.ETHR) THEN
16602 PCAS1(K) = PCAS(ICAS,K)
16604 * "absorb" negative particle in nucleus
16605 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16606 IF (IREJ1.NE.0) GOTO 9999
16607 IF (NSPE.GE.1) LABSOR = .TRUE.
16611 * if the initial particle has not been absorbed proceed with
16613 IF (.NOT.LABSOR) THEN
16615 * calculate coordinates of hadron at the end of the formation zone
16616 * transport-time and -step in the rest system where this step is
16619 DTIME = DSTEP/BECAS(ICAS)
16621 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16622 RTIME = RSTEP/BECAS(I2)
16626 * save step whithout considering the overlapping region
16627 DSTEP1 = DEL1*FM2MM
16628 DTIME1 = DSTEP1/BECAS(ICAS)
16629 RSTEP1 = REL1*FM2MM
16630 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16631 RTIME1 = RSTEP1/BECAS(I2)
16635 * transport to the end of the formation zone in this system
16637 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16638 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
16639 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16640 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
16642 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16643 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
16644 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16645 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
16647 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16648 XCAS = VTXCAS(ICAS,1)
16649 YCAS = VTXCAS(ICAS,2)
16650 XNCLTA = BIMPAC*FM2MM
16651 RNCLPR = (RPROJ+RNUCLE)*FM2MM
16652 RNCLTA = (RTARG+RNUCLE)*FM2MM
16653 C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16654 C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16655 C RNCLPR = (RPROJ)*FM2MM
16656 C RNCLTA = (RTARG)*FM2MM
16657 RCASPR = SQRT( XCAS**2 +YCAS**2)
16658 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16659 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16660 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16664 * check if particle is already outside of the corresp. nucleus
16665 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16666 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16667 IF (RDIST.GE.RNUC(ICAS)) THEN
16668 * here: IDCH is the generation of the final state part. starting
16669 * with zero for hadronization products
16670 * flag particles of generation 0 being outside the nuclei after
16671 * formation time (to be used for excitation energy calculation)
16672 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16673 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16682 * already here: skip particles being outside HADRIN "energy-window"
16683 * to avoid wasting of time
16684 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16685 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16686 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16687 C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16688 C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
16689 C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16690 C & E12.4,', above or below HADRIN-thresholds',I6)
16695 DO 7 IDXHKK=1,NOINC
16697 * scan DTEVT1 for unwounded or excited nucleons
16698 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16700 IF (ICAS.EQ.1) THEN
16701 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16702 ELSEIF (ICAS.EQ.2) THEN
16703 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16706 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16707 & VTXDST(2)*COSCAS(ICAS,2)+
16708 & VTXDST(3)*COSCAS(ICAS,3)
16709 * check if nucleon is situated in forward direction
16710 IF (POSNUC.GT.ZERO) THEN
16711 * distance between hadron and this nucleon
16712 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16715 BIMNU2 = DISTNU**2-POSNUC**2
16716 IF (BIMNU2.LT.ZERO) THEN
16717 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16718 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
16719 & ' parameter ',/,20X,3E12.4)
16722 BIMNU = SQRT(BIMNU2)
16723 * maximum impact parameter to have interaction
16724 IDNUC = IDT_ICIHAD(IDHKK(I))
16725 IDNUC1 = IDT_MCHAD(IDNUC)
16726 IDCAS1 = IDT_MCHAD(IDCAS)
16728 PCAS1(K) = PCAS(ICAS,K)
16729 PNUC(K) = PHKK(K,I)
16731 * Lorentz-parameter for trafo into rest-system of target
16733 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16735 * transformation of projectile into rest-system of target
16736 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16737 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16738 & PPTOT,PX,PY,PZ,PE)
16740 C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16741 C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16743 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16744 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16745 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16746 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16747 SIGIN = SIGTOT-SIGEL-SIGAB
16748 C SIGTOT = SIGIN+SIGEL+SIGAB
16750 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16751 * check if interaction is possible
16752 IF (BIMNU.LE.BIMMAX) THEN
16753 * get nucleon with smallest distance and kind of interaction
16754 * (elastic/inelastic)
16755 IF (DISTNU.LT.DIST) THEN
16758 IF (IDNUC.NE.IDSPE(1)) THEN
16759 IDSPE(2) = IDSPE(1)
16760 IDXSPE(2) = IDXSPE(1)
16769 C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16771 C STOT = SIGIN+SIGEL
16773 C SELA = SIGEL+0.75D0*SIGIN
16774 C STOT = 0.25D0*SIGIN+SELA
16780 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16782 IDNUC = IDT_ICIHAD(IDHKK(I))
16783 IF (IDNUC.EQ.1) THEN
16784 IF (DISTNU.LT.DISTP) THEN
16789 ELSEIF (IDNUC.EQ.8) THEN
16790 IF (DISTNU.LT.DISTN) THEN
16799 * there is no nucleon for a secondary interaction
16800 IF (NSPE.EQ.0) GOTO 9997
16802 C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16803 C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16804 IF (IDXSPE(2).EQ.0) THEN
16805 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16807 C IF (ICAS.EQ.1) THEN
16808 C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16809 C ELSEIF (ICAS.EQ.2) THEN
16810 C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16813 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16815 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16822 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16824 C IF (ICAS.EQ.1) THEN
16825 C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16826 C ELSEIF (ICAS.EQ.2) THEN
16827 C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16830 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16832 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16845 IF (RR.LT.SELA/STOT) THEN
16847 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16854 PCAS1(K) = PCAS(ICAS,K)
16855 PNUC(K) = PHKK(K,IDXSPE(1))
16857 IF (IPROC.EQ.3) THEN
16858 * 2-nucleon absorption of pion
16860 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16861 IF (IREJ1.NE.0) GOTO 9999
16862 IF (NSPE.GE.1) LABSOR = .TRUE.
16864 * sample secondary interaction
16865 IDNUC = IDBAM(IDXSPE(1))
16866 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16867 IF (IREJ1.EQ.1) GOTO 9999
16868 IF (IREJ1.GT.1) GOTO 9998
16872 * update arrays to include Pauli-principle
16874 IF (NWOUND(ICAS).LE.299) THEN
16875 NWOUND(ICAS) = NWOUND(ICAS)+1
16876 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16880 * dump initial hadron for energy-momentum conservation check
16882 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16883 & PCAS(ICAS,4),1,IDUM,IDUM)
16885 * dump final state particles into DTEVT1
16887 * check if Pauli-principle is fulfilled
16889 NWTMP(1) = NWOUND(1)
16890 NWTMP(2) = NWOUND(2)
16894 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16895 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16897 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16904 IF (IDX.EQ.1) MODE = -1
16905 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16907 * first check if cascade step is forbidden due to Pauli-principle
16908 * (in case of absorpion this step is forced)
16909 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16910 & (IDFSP(I).EQ.8))) THEN
16911 * get nuclear potential barrier
16912 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16913 IF (IDFSP(I).EQ.1) THEN
16914 POTLOW = POT-EBINDP(IDX)
16916 POTLOW = POT-EBINDN(IDX)
16918 * final state particle not able to escape nucleus
16919 IF (PE.LE.POTLOW) THEN
16920 * check if there are wounded nucleons
16921 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16922 & EWOUND(IDX,NWOUND(IDX)))) THEN
16924 NWOUND(IDX) = NWOUND(IDX)-1
16926 * interaction prohibited by Pauli-principle
16927 NWOUND(1) = NWTMP(1)
16928 NWOUND(2) = NWTMP(2)
16937 NWOUND(1) = NWTMP(1)
16938 NWOUND(2) = NWTMP(2)
16942 IST = ISTHKK(IDXCAS)
16946 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16947 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16949 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16954 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16956 * first check if cascade step is forbidden due to Pauli-principle
16957 * (in case of absorpion this step is forced)
16958 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16959 & (IDFSP(I).EQ.8))) THEN
16960 * get nuclear potential barrier
16961 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16962 IF (IDFSP(I).EQ.1) THEN
16963 POTLOW = POT-EBINDP(IDX)
16965 POTLOW = POT-EBINDN(IDX)
16967 * final state particle not able to escape nucleus
16968 IF (PE.LE.POTLOW) THEN
16969 * check if there are wounded nucleons
16970 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16971 & EWOUND(IDX,NWOUND(IDX)))) THEN
16972 NWOUND(IDX) = NWOUND(IDX)-1
16976 * interaction prohibited by Pauli-principle
16977 NWOUND(1) = NWTMP(1)
16978 NWOUND(2) = NWTMP(2)
16982 c ELSEIF (PE.LE.POT) THEN
16983 cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16984 cC NWOUND(IDX) = NWOUND(IDX)-1
16986 c NPAULI = NPAULI+1
16992 * dump final state particles for energy-momentum conservation check
16993 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16994 & -PFSP(4,I),2,IDUM,IDUM)
17000 IF (ABS(IST).EQ.1) THEN
17001 * transform particles back into n-n cms
17002 * LEPTO: leave final state particles in target rest frame
17003 C IF (MCGENE.EQ.3) THEN
17010 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17011 & PFSP(4,I),IDFSP(I),IMODE)
17013 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17014 * target cascade but fsp got stuck in proj. --> transform it into
17015 * proj. rest system
17016 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17017 & PFSP(4,I),IDFSP(I),-1)
17018 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17019 * proj. cascade but fsp got stuck in target --> transform it into
17020 * target rest system
17021 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17022 & PFSP(4,I),IDFSP(I),1)
17025 * dump final state particles into DTEVT1
17026 IGEN = IDCH(IDXCAS)+1
17027 ID = IDT_IPDGHA(IDFSP(I))
17029 IF (LABSOR) IXR = 99
17030 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17031 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17033 * update the counter for particles which got stuck inside the nucleus
17034 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17036 IDXINC(NOINC) = NHKK
17039 * in case of absorption the spatial treatment is an approximate
17040 * solution anyway (the positions of the nucleons which "absorb" the
17041 * cascade particle are not taken into consideration) therefore the
17042 * particles are produced at the position of the cascade particle
17044 WHKK(K,NHKK) = WHKK(K,IDXCAS)
17045 VHKK(K,NHKK) = VHKK(K,IDXCAS)
17048 * DDISTL - distance the cascade particle moves to the intera. point
17049 * (the position where impact-parameter = distance to the interacting
17050 * nucleon), DIST - distance to the interacting nucleon at the time of
17051 * formation of the cascade particle, BINT - impact-parameter of this
17052 * cascade-interaction
17053 DDISTL = SQRT(DIST**2-BINT**2)
17054 DTIME = DDISTL/BECAS(ICAS)
17055 DTIMEL = DDISTL/BGCAS(ICAS)
17056 RDISTL = DTIMEL*BGCAS(I2)
17057 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17058 RTIME = RDISTL/BECAS(I2)
17062 * RDISTL, RTIME are this step and time in the rest system of the other
17065 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17066 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
17068 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17069 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
17070 * position of particle production is half the impact-parameter to
17071 * the interacting nucleon
17073 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17074 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17076 * time of production of secondary = time of interaction
17077 WHKK(4,NHKK) = VTXCA1(1,4)
17078 VHKK(4,NHKK) = VTXCA1(2,4)
17083 * modify status and position of cascade particle (the latter for
17084 * statistics reasons only)
17086 IF (LABSOR) ISTHKK(IDXCAS) = 19
17087 IF (.NOT.LABSOR) THEN
17089 WHKK(K,IDXCAS) = VTXCA1(1,K)
17090 VHKK(K,IDXCAS) = VTXCA1(2,K)
17096 * dump interacting nucleons for energy-momentum conservation check
17098 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17100 * modify entry for interacting nucleons
17101 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17102 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17104 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17105 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17109 * check energy-momentum conservation
17111 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17112 IF (IREJ1.NE.0) GOTO 9999
17117 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17119 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17120 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17127 * transport-step but no cascade step due to configuration (i.e. there
17128 * is no nucleon for interaction etc.)
17131 C WHKK(K,IDXCAS) = VTXCAS(1,K)
17132 C VHKK(K,IDXCAS) = VTXCAS(2,K)
17133 WHKK(K,IDXCAS) = VTXCA1(1,K)
17134 VHKK(K,IDXCAS) = VTXCA1(2,K)
17139 * no cascade-step because of configuration
17140 * (i.e. hadron outside nucleus etc.)
17150 *===absorp=============================================================*
17152 CDECK ID>, DT_ABSORP
17153 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17155 ************************************************************************
17156 * Two-nucleon absorption of antiprotons, pi-, and K-. *
17157 * Antiproton absorption is handled by HADRIN. *
17158 * The following channels for meson-absorption are considered: *
17159 * pi- + p + p ---> n + p *
17160 * pi- + p + n ---> n + n *
17161 * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
17162 * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
17163 * K- + p + p ---> sigma- + n *
17164 * IDCAS, PCAS identity, momentum of particle to be absorbed *
17165 * NCAS = 1 intranuclear cascade in projectile *
17166 * = -1 intranuclear cascade in target *
17167 * NSPE number of spectator nucleons involved *
17168 * IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
17169 * Revised version of the original STOPIK written by HJM and J. Ranft. *
17170 * This version dated 24.02.95 is written by S. Roesler *
17171 ************************************************************************
17173 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17176 PARAMETER ( LINP = 5 ,
17180 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17181 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17185 PARAMETER (NMXHKK=200000)
17187 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17188 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17189 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17190 * extended event history
17191 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17192 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17194 * flags for input different options
17195 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17196 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17197 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17198 * final state after inc step
17199 PARAMETER (MAXFSP=10)
17200 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17201 * particle properties (BAMJET index convention)
17203 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17204 & IICH(210),IIBAR(210),K1(210),K2(210)
17206 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17207 & PTOT3P(4),BG3P(4),
17208 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17213 * skip particles others than ap, pi-, K- for mode=0
17214 IF ((MODE.EQ.0).AND.
17215 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17216 * skip particles others than pions for mode=1
17217 * (2-nucleon absorption in intranuclear cascade)
17218 IF ((MODE.EQ.1).AND.
17219 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17222 IF (NUCAS.EQ.-1) NUCAS = 2
17224 IF (MODE.EQ.0) THEN
17225 * scan spectator nucleons for nucleons being able to "absorb"
17230 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17233 IDSPE(NSPE) = IDBAM(I)
17234 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17235 IF (NSPE.EQ.2) THEN
17236 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17237 & (IDSPE(2).EQ.8)) THEN
17238 * there is no pi-+n+n channel
17250 * transform excited projectile nucleons (status=15) into proj. rest s.
17253 PSPE(I,K) = PHKK(K,IDXSPE(I))
17257 * antiproton absorption
17258 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17260 PSPE1(K) = PSPE(1,K)
17262 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17263 IF (IREJ1.NE.0) GOTO 9999
17266 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17267 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17268 IF (IDCAS.EQ.14) THEN
17272 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17273 ELSEIF (IDCAS.EQ.13) THEN
17277 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17278 ELSEIF (IDCAS.EQ.23) THEN
17280 IDFSP(1) = IDSPE(1)
17281 IDFSP(2) = IDSPE(2)
17282 ELSEIF (IDCAS.EQ.16) THEN
17285 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17286 IF (R.LT.ONETHI) THEN
17289 ELSEIF (R.LT.TWOTHI) THEN
17296 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17300 IF (R.LT.ONETHI) THEN
17303 ELSEIF (R.LT.TWOTHI) THEN
17312 * dump initial particles for energy-momentum cons. check
17314 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17315 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17317 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17320 * get Lorentz-parameter of 3 particle initial state
17322 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17324 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17325 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17327 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17329 * 2-particle decay of the 3-particle compound system
17330 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17331 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17332 & AAM(IDFSP(1)),AAM(IDFSP(2)))
17334 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17335 PX = PCMF(I)*COFF(I)*SDF
17336 PY = PCMF(I)*SIFF(I)*SDF
17337 PZ = PCMF(I)*CODF(I)
17338 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17339 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17341 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17342 * check consistency of kinematics
17343 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17344 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17345 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
17346 & ' tree-particle kinematics',/,20X,'id: ',I3,
17347 & ' AAM = ',E10.4,' MFSP = ',E10.4)
17349 * dump final state particles for energy-momentum cons. check
17350 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17351 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17355 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17356 IF (IREJ1.NE.0) THEN
17357 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17363 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17364 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
17365 & ' impossible',/,20X,'too few spectators (',I2,')')
17372 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17377 *===hadrin=============================================================*
17379 CDECK ID>, DT_HADRIN
17380 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17382 ************************************************************************
17383 * Interface to the HADRIN-routines for inelastic and elastic *
17385 * IDPR,PPR(5) identity, momentum of projectile *
17386 * IDTA,PTA(5) identity, momentum of target *
17387 * MODE = 1 inelastic interaction *
17388 * = 2 elastic interaction *
17389 * Revised version of the original FHAD. *
17390 * This version dated 27.10.95 is written by S. Roesler *
17391 ************************************************************************
17393 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17396 PARAMETER ( LINP = 5 ,
17400 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17401 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17403 LOGICAL LCORR,LMSSG
17405 * flags for input different options
17406 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17407 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17408 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17409 * final state after inc step
17410 PARAMETER (MAXFSP=10)
17411 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17412 * particle properties (BAMJET index convention)
17414 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17415 & IICH(210),IIBAR(210),K1(210),K2(210)
17416 * output-common for DHADRI/ELHAIN
17417 * final state from HADRIN interaction
17418 PARAMETER (MAXFIN=10)
17419 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17420 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17422 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17423 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17425 DATA LMSSG /.TRUE./
17434 * dump initial particles for energy-momentum cons. check
17436 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17437 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17440 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17441 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17442 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17443 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17444 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17445 IF (LMSSG.AND.(IOULEV(3).GT.0))
17446 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17447 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
17448 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17449 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17454 * convert initial state particles into particles which can be
17455 * handled by HADRIN
17458 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17459 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17466 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17467 IF (IREJ1.GT.0) THEN
17468 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17475 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17476 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17479 * Lorentz-parameter for trafo into rest-system of target
17481 BGTA(K) = PTA(K)/PTA(5)
17483 * transformation of projectile into rest-system of target
17484 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17485 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17488 * direction cosines of projectile in target rest system
17489 CX = PPR1(1)/PPRTO1
17490 CY = PPR1(2)/PPRTO1
17491 CZ = PPR1(3)/PPRTO1
17493 * sample inelastic interaction
17494 IF (MODE.EQ.1) THEN
17495 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17496 IF (IRH.EQ.1) GOTO 9998
17497 * sample elastic interaction
17498 ELSEIF (MODE.EQ.2) THEN
17499 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17500 IF (IREJ1.NE.0) THEN
17501 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17504 IF (IRH.EQ.1) GOTO 9998
17506 WRITE(LOUT,1001) MODE,INTHAD
17507 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
17508 & I4,' (INTHAD =',I4,')')
17512 * transform final state particles back into Lab.
17515 PX = CXRH(I)*PLRH(I)
17516 PY = CYRH(I)*PLRH(I)
17517 PZ = CZRH(I)*PLRH(I)
17518 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17519 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17520 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17521 IDFSP(NFSP) = ITRH(I)
17522 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17524 IF (AMFSP2.LT.-TINY3) THEN
17525 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17526 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17527 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
17528 & I2,') with negative mass^2',/,1X,5E12.4)
17531 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17532 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17533 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17535 1003 FORMAT(1X,'HADRIN: warning! final state particle',
17536 & ' (id = ',I2,') with inconsistent mass',/,1X,
17539 IF (KCORR.GT.2) GOTO 9999
17540 IMCORR(KCORR) = NFSP
17543 * dump final state particles for energy-momentum cons. check
17544 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17545 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17548 * transform momenta on mass shell in case of inconsistencies in
17550 IF (KCORR.GT.0) THEN
17551 IF (KCORR.EQ.2) THEN
17555 IF (IMCORR(1).EQ.1) THEN
17563 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17564 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17565 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17566 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17568 P1IN(K) = PFSP(K,I1)
17569 P2IN(K) = PFSP(K,I2)
17571 XM1 = AAM(IDFSP(I1))
17572 XM2 = AAM(IDFSP(I2))
17573 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17574 IF (IREJ1.GT.0) THEN
17575 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17579 PFSP(K,I1) = P1OUT(K)
17580 PFSP(K,I2) = P2OUT(K)
17582 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17583 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
17584 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17585 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
17586 * dump final state particles for energy-momentum cons. check
17587 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17588 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17589 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17590 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17593 * check energy-momentum conservation
17595 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17596 IF (IREJ1.NE.0) GOTO 9999
17610 *===hadcol=============================================================*
17612 CDECK ID>, DT_HADCOL
17613 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17615 ************************************************************************
17616 * Interface to the HADRIN-routines for inelastic and elastic *
17617 * scattering. This subroutine samples hadron-nucleus interactions *
17618 * below DPM-threshold. *
17619 * IDPROJ BAMJET-index of projectile hadron *
17620 * PPN projectile momentum in target rest frame *
17621 * IDXTAR DTEVT1-index of target nucleon undergoing *
17622 * interaction with projectile hadron *
17623 * This subroutine replaces HADHAD. *
17624 * This version dated 5.5.95 is written by S. Roesler *
17625 ************************************************************************
17627 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17630 PARAMETER ( LINP = 5 ,
17634 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17640 PARAMETER (NMXHKK=200000)
17642 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17643 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17644 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17645 * extended event history
17646 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17647 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17649 * nuclear potential
17651 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17652 & EBINDP(2),EBINDN(2),EPOT(2,210),
17653 & ETACOU(2),ICOUL,LFERMI
17654 * interface HADRIN-DPM
17655 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17656 * parameter for intranuclear cascade
17658 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17659 * final state after inc step
17660 PARAMETER (MAXFSP=10)
17661 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17662 * particle properties (BAMJET index convention)
17664 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17665 & IICH(210),IIBAR(210),K1(210),K2(210)
17667 DIMENSION PPROJ(5),PNUC(5)
17669 DATA LSTART /.TRUE./
17676 **sr 6/9/01 commented
17677 C TAUFOR = TAUFOR/2.0D0
17681 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
17682 WRITE(LOUT,1001) TAUFOR
17683 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
17688 IDNUC = IDBAM(IDXTAR)
17689 IDNUC1 = IDT_MCHAD(IDNUC)
17690 IDPRO1 = IDT_MCHAD(IDPROJ)
17692 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17696 C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17697 C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17699 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17700 SIGIN = SIGTOT-SIGEL
17701 C SIGTOT = SIGIN+SIGEL
17704 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17710 PPROJ(5) = AAM(IDPROJ)
17711 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17713 PNUC(K) = PHKK(K,IDXTAR)
17719 IF (ILOOP.GT.100) GOTO 9999
17721 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17722 IF (IREJ1.EQ.1) GOTO 9999
17724 IF (IREJ1.GT.1) THEN
17725 * no interaction possible
17726 * require Pauli blocking
17727 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17728 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17729 IF ((IIBAR(IDPROJ).NE.1).AND.
17730 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
17731 * store incoming particle as final state particle
17732 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17733 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17736 * require Pauli blocking for final state nucleons
17738 IF ((IDFSP(I).EQ.1).AND.
17739 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
17740 IF ((IDFSP(I).EQ.8).AND.
17741 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
17742 IF ((IIBAR(IDFSP(I)).NE.1).AND.
17743 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17745 * store final state particles
17748 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17749 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17750 IDHAD = IDT_IPDGHA(IDFSP(I))
17751 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17752 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17754 IF (I.EQ.1) NPOINT(4) = NHKK
17755 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17756 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17757 VHKK(3,NHKK) = VHKK(3,IDXTAR)
17758 VHKK(4,NHKK) = VHKK(4,IDXTAR)
17759 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17760 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17761 WHKK(3,NHKK) = WHKK(3,1)
17762 WHKK(4,NHKK) = WHKK(4,1)
17774 *===getemu=============================================================*
17776 CDECK ID>, DT_GETEMU
17777 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17779 ************************************************************************
17780 * Sampling of emulsion component to be considered as target-nucleus. *
17781 * This version dated 6.5.95 is written by S. Roesler. *
17782 ************************************************************************
17784 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17787 PARAMETER ( LINP = 5 ,
17791 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17793 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17795 * emulsion treatment
17796 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17798 * Glauber formalism: flags and parameters for statistics
17801 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17803 IF (MODE.EQ.0) THEN
17805 RR = DT_RNDM(SUMFRA)
17808 DO 1 ICOMP=1,NCOMPO
17809 SUMFRA = SUMFRA+EMUFRA(ICOMP)
17810 IF (SUMFRA.GT.RR) THEN
17812 ITZ = IEMUCH(ICOMP)
17819 WRITE(LOUT,'(1X,A,E12.3)')
17820 & 'Warning! norm. failure within emulsion fractions',
17824 ELSEIF (MODE.EQ.1) THEN
17827 IDIFF = ABS(IT-IEMUMA(I))
17828 IF (IDIFF.LT.NDIFF) THEN
17837 * bypass for variable projectile/target/energy runs: the correct
17838 * Glauber data will be always loaded on kkmat=1
17839 IF (IOGLB.EQ.100) THEN
17846 *===nclpot=============================================================*
17848 CDECK ID>, DT_NCLPOT
17849 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17851 ************************************************************************
17852 * Calculation of Coulomb and nuclear potential for a given configurat. *
17853 * IPZ, IP charge/mass number of proj. *
17854 * ITZ, IT charge/mass number of targ. *
17855 * AFERP,AFERT factors modifying proj./target pot. *
17856 * if =0, FERMOD is used *
17857 * MODE = 0 calculation of binding energy *
17858 * = 1 pre-calculated binding energy is used *
17859 * This version dated 16.11.95 is written by S. Roesler. *
17860 ************************************************************************
17862 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17865 PARAMETER ( LINP = 5 ,
17869 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17874 * particle properties (BAMJET index convention)
17876 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17877 & IICH(210),IIBAR(210),K1(210),K2(210)
17878 * nuclear potential
17880 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17881 & EBINDP(2),EBINDN(2),EPOT(2,210),
17882 & ETACOU(2),ICOUL,LFERMI
17884 DIMENSION IDXPOT(14)
17885 * ap an lam alam sig- sig+ sig0 tet0 tet- asig-
17886 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
17887 * asig0 asig+ atet0 atet+
17888 & 100, 101, 102, 103/
17891 DATA LSTART /.TRUE./
17893 IF (MODE.EQ.0) THEN
17905 IF (AFERP.LE.ZERO) FERMIP = FERMOD
17907 IF (AFERT.LE.ZERO) FERMIT = FERMOD
17909 * Fermi momenta and binding energy for projectile
17910 IF ((IP.GT.1).AND.LFERMI) THEN
17911 IF (MODE.EQ.0) THEN
17912 C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17913 C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17917 EBINDP(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ)
17918 & -ENERGY(BIP,BIPZ))
17920 IF (AIP.LE.AIPZ) THEN
17921 EBINDN(1) = EBINDP(1)
17922 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17925 EBINDN(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ)
17926 & -ENERGY(BIP,AIPZ))
17930 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17931 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17936 * effective nuclear potential for projectile
17937 C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17938 C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17939 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17940 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17942 * Fermi momenta and binding energy for target
17943 IF ((IT.GT.1).AND.LFERMI) THEN
17944 IF (MODE.EQ.0) THEN
17945 C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17946 C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17950 EBINDP(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ)
17951 & -ENERGY(BIT,BITZ))
17953 IF (AIT.LE.AITZ) THEN
17954 EBINDN(2) = EBINDP(2)
17955 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17958 EBINDN(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ)
17959 & -ENERGY(BIT,AITZ))
17963 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17964 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17969 * effective nuclear potential for target
17970 C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17971 C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17972 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17973 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17976 EPOT(1,IDXPOT(I)) = EPOT(1,8)
17977 EPOT(2,IDXPOT(I)) = EPOT(2,8)
17983 IF (ICOUL.EQ.1) THEN
17985 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17987 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17991 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17992 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17993 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17995 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
17996 & ,' effects',/,12X,'---------------------------',
17997 & '----------------',/,/,38X,'projectile',
17998 & ' target',/,/,1X,'Mass number / charge',
17999 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
18000 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
18001 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
18002 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
18003 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
18004 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
18011 *===resncl=============================================================*
18013 CDECK ID>, DT_RESNCL
18014 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18016 ************************************************************************
18017 * Treatment of residual nuclei and nuclear effects. *
18018 * MODE = 1 initializations *
18019 * = 2 treatment of final state *
18020 * This version dated 16.11.95 is written by S. Roesler. *
18021 ************************************************************************
18023 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18026 PARAMETER ( LINP = 5 ,
18030 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18031 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18032 & ONETHI=ONE/THREE)
18033 PARAMETER (AMUAMU = 0.93149432D0,
18039 PARAMETER (NMXHKK=200000)
18041 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18042 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18043 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18044 * extended event history
18045 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18046 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18048 * particle properties (BAMJET index convention)
18050 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18051 & IICH(210),IIBAR(210),K1(210),K2(210)
18052 * flags for input different options
18053 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18054 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18055 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18056 * nuclear potential
18058 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18059 & EBINDP(2),EBINDN(2),EPOT(2,210),
18060 & ETACOU(2),ICOUL,LFERMI
18061 * properties of interacting particles
18062 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18063 * properties of photon/lepton projectiles
18064 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18065 * Lorentz-parameters of the current interaction
18066 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18067 & UMO,PPCM,EPROJ,PPROJ
18068 * treatment of residual nuclei: wounded nucleons
18069 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18070 * treatment of residual nuclei: 4-momenta
18071 LOGICAL LRCLPR,LRCLTA
18072 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18073 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18075 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18076 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18077 & IDXCOR(15000),IDXOTH(NMXHKK)
18081 *------- initializations
18084 * initialize arrays for residual nuclei
18099 * correction of projectile 4-momentum for effective target pot.
18100 * and Coulomb-energy (in case of hadron-nucleus interaction only)
18101 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18104 * positively charged hadron - check energy for Coloumb pot.
18105 IF (IICH(IJPROJ).EQ.1) THEN
18106 THRESH = ETACOU(2)+AAM(IJPROJ)
18107 IF (EPNI.LE.THRESH) THEN
18109 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
18110 & ' below Coulomb threshold - event rejected',/)
18114 * negatively charged hadron - increase energy by Coulomb energy
18115 ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18116 EPNI = EPNI+ETACOU(2)
18118 IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18119 * Effective target potential
18120 *sr 6.6. binding energy only (to avoid negative exc. energies)
18121 C EPNI = EPNI+EPOT(2,IJPROJ)
18123 IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18124 & EBIPOT = EBINDN(2)
18125 EPNI = EPNI+ABS(EBIPOT)
18126 * re-initialization of DTLTRA
18129 CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18133 * projectile in n-n cms
18134 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18135 PMASS1 = AAM(IJPROJ)
18137 C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18138 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18140 PM1 = SIGN(PMASS1**2,PMASS1)
18141 PM2 = SIGN(PMASS2**2,PMASS2)
18142 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18144 IF (PMASS1.GT.ZERO) THEN
18145 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18146 & *(PINIPR(4)+PINIPR(5)))
18148 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18153 PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18155 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18156 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18158 PMASS2 = AAM(IJTARG)
18159 PM1 = SIGN(PMASS1**2,PMASS1)
18160 PM2 = SIGN(PMASS2**2,PMASS2)
18161 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18163 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18164 & *(PINITA(4)+PINITA(5)))
18168 PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18170 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18171 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18175 PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18177 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18181 PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18183 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18188 *------- treatment of final state
18192 IF (NLOOP.GT.1) SCPOT = 0.10D0
18193 C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18205 DO 900 I=NPOINT(4),NHKK
18207 IF (ISTHKK(I).EQ.1) THEN
18208 IF (IDBAM(I).EQ.7) GOTO 900
18211 * particle moving into forward direction
18212 IF (PHKK(3,I).GE.ZERO) THEN
18213 * most likely to be effected by projectile potential
18215 * there is no projectile nucleus, try target
18216 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18218 IF (IP.GT.1) IOTHER = 1
18219 * there is no target nucleus --> skip
18220 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18222 * particle moving into backward direction
18224 * most likely to be effected by target potential
18226 * there is no target nucleus, try projectile
18227 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18229 IF (IT.GT.1) IOTHER = 1
18230 * there is no projectile nucleus --> skip
18231 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18235 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18236 * =1: particle is not in overlap-region AND is inside target (2)
18237 * =2: particle is not in overlap-region AND is inside projectile (1)
18238 * flag particles which are inside the nucleus ipot but not in its
18240 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18241 * baryons: keep all nucleons and all others where flag is set
18242 IF (IIBAR(IDBAM(I)).NE.0) THEN
18243 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18246 PMOMB(NOB) = PHKK(3,I)
18247 IDXB(NOB) = SIGN(1000000*IABS(IFLG)
18248 & +100000*IOTHER+I,IFLG)
18250 * mesons: keep only those mesons where flag is set
18252 IF (IFLG.GT.0) THEN
18254 PMOMM(NOM) = PHKK(3,I)
18255 IDXM(NOM) = 1000000*IFLG+100000*IOTHER+I
18261 * sort particles in the arrays according to increasing long. momentum
18262 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18263 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18265 * shuffle indices into one and the same array according to the later
18266 * sequence of correction
18270 IF (PMOMB(I).GT.ZERO) GOTO 911
18272 IDXCOR(NCOR) = IDXB(I)
18278 IF (PMOMB(I).LT.ZERO) GOTO 913
18280 IDXCOR(NCOR) = IDXB(I)
18285 IF (PMOMB(I).GT.ZERO) THEN
18287 IDXCOR(NCOR) = IDXB(I)
18295 IDXCOR(NCOR) = IDXB(I)
18299 IF (PMOMM(I).GT.ZERO) GOTO 926
18301 IDXCOR(NCOR) = IDXM(I)
18306 IF (PMOMM(I).LT.ZERO) GOTO 928
18308 IDXCOR(NCOR) = IDXM(I)
18312 C IF (NEVHKK.EQ.484) THEN
18313 C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18314 C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
18315 C WRITE(LOUT,9001) NOB,NOM,NCOR
18316 C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18317 C WRITE(LOUT,'(/,A)') ' baryons '
18319 CC J = IABS(IDXB(I))
18320 CC INDEX = J-IABS(J/1000000)*1000000
18321 C IPOT = IABS(IDXB(I))/1000000
18322 C IOTHER = IABS(IDXB(I))/100000-IPOT*10
18323 C INDEX = IABS(IDXB(I))-IPOT*1000000-IOTHER*100000
18324 C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18326 C WRITE(LOUT,'(/,A)') ' mesons '
18328 CC INDEX = IDXM(I)-IABS(IDXM(I)/1000000)*1000000
18329 C IPOT = IABS(IDXM(I))/1000000
18330 C IOTHER = IABS(IDXM(I))/100000-IPOT*10
18331 C INDEX = IABS(IDXM(I))-IPOT*1000000-IOTHER*100000
18332 C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18334 C 9002 FORMAT(1X,4I14,E14.5)
18335 C WRITE(LOUT,'(/,A)') ' all '
18337 CC J = IABS(IDXCOR(I))
18338 CC INDEX = J-IABS(J/1000000)*1000000
18339 CC IPOT = IABS(IDXCOR(I))/1000000
18340 C IOTHER = IABS(IDXCOR(I))/100000-IPOT*10
18341 C INDEX = IABS(IDXCOR(I))-IPOT*1000000-IOTHER*100000
18342 C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18344 C 9003 FORMAT(1X,4I14)
18348 IPOT = IABS(IDXCOR(ICOR))/1000000
18349 IOTHER = IABS(IDXCOR(ICOR))/100000-IPOT*10
18350 I = IABS(IDXCOR(ICOR))-IPOT*1000000-IOTHER*100000
18355 * reduction of particle momentum by corresponding nuclear potential
18356 * (this applies only if Fermi-momenta are requested)
18360 * Lorentz-transformation into the rest system of the selected nucleus
18362 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18363 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18364 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18365 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18369 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18370 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18371 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18372 IF (IOULEV(3).GT.0)
18373 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18374 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
18375 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18376 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
18384 * the correction for nuclear potential effects is applied to as many
18385 * p/n as many nucleons were wounded; the momenta of other final state
18386 * particles are corrected only if they materialize inside the corresp.
18387 * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18388 * = 3 part. outside proj. and targ., >=10 in overlapping region)
18389 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18390 IF (IPOT.EQ.1) THEN
18391 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18392 * this is most likely a wounded nucleon
18394 C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18395 C & +(VHKK(2,IPW(JPW))/FM2MM)**2
18396 C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
18397 C RAD = RNUCLE*DBLE(IP)**ONETHI
18398 C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18399 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18401 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18405 * correct only if part. was materialized inside nucleus
18406 * and if it is ouside the overlapping region
18407 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18408 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18412 ELSEIF (IPOT.EQ.2) THEN
18413 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18414 * this is most likely a wounded nucleon
18416 C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18417 C & +(VHKK(2,ITW(JTW))/FM2MM)**2
18418 C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
18419 C RAD = RNUCLE*DBLE(IT)**ONETHI
18420 C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18421 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18423 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18427 * correct only if part. was materialized inside nucleus
18428 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18429 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18435 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18436 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18441 IF (NLOOP.EQ.1) THEN
18442 * Coulomb energy correction:
18443 * the treatment of Coulomb potential correction is similar to the
18444 * one for nuclear potential
18445 IF (IDSEC.EQ.1) THEN
18446 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18448 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18451 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18454 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18456 IF (IICH(IDSEC).EQ.1) THEN
18457 * pos. particles: check if they are able to escape Coulomb potential
18458 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18459 ISTHKK(I) = 14+IPOT
18460 IF (ISTHKK(I).EQ.15) THEN
18462 PHKK(K,I) = PSEC0(K)
18463 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18465 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18466 IF (IDSEC.EQ.1) NPCW = NPCW-1
18467 ELSEIF (ISTHKK(I).EQ.16) THEN
18469 PHKK(K,I) = PSEC0(K)
18470 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18472 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18473 IF (IDSEC.EQ.1) NTCW = NTCW-1
18477 ELSEIF (IICH(IDSEC).EQ.-1) THEN
18478 * neg. particles: decrease energy by Coulomb-potential
18479 PSEC(4) = PSEC(4)-ETACOU(IPOT)
18486 IF (PSEC(4).LT.AMSEC) THEN
18487 IF (IOULEV(6).GT.0)
18488 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18489 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18490 & ' is not allowed to escape nucleus',/,
18491 & 8X,'id : ',I3,' reduced energy: ',E15.4,
18493 ISTHKK(I) = 14+IPOT
18494 IF (ISTHKK(I).EQ.15) THEN
18496 PHKK(K,I) = PSEC0(K)
18497 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18499 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18500 IF (IDSEC.EQ.1) NPCW = NPCW-1
18501 ELSEIF (ISTHKK(I).EQ.16) THEN
18503 PHKK(K,I) = PSEC0(K)
18504 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18506 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18507 IF (IDSEC.EQ.1) NTCW = NTCW-1
18512 IF (JPMOD.EQ.1) THEN
18513 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18514 * 4-momentum after correction for nuclear potential
18516 PSEC(K) = PSEC(K)*PSECN/PSECO
18519 * store recoil momentum from particles escaping the nuclear potentials
18521 IF (IPOT.EQ.1) THEN
18522 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18523 ELSEIF (IPOT.EQ.2) THEN
18524 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18528 * transform momentum back into n-n cms
18530 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18531 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18539 PFSP(K) = PFSP(K)+PHKK(K,I)
18544 DO 33 I=NPOINT(4),NHKK
18545 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18546 PFSP(1) = PFSP(1)+PHKK(1,I)
18547 PFSP(2) = PFSP(2)+PHKK(2,I)
18548 PFSP(3) = PFSP(3)+PHKK(3,I)
18549 PFSP(4) = PFSP(4)+PHKK(4,I)
18554 PRCLPR(K) = TRCLPR(K)
18555 PRCLTA(K) = TRCLTA(K)
18558 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18559 * hadron-nucleus interactions: get residual momentum from energy-
18560 * momentum conservation
18563 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18566 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18567 * accumulated recoil momenta of particles leaving the spectators
18568 * transform accumulated recoil momenta of residual nuclei into
18572 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18575 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18576 C IF (IP.GT.1) THEN
18577 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18578 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18581 PRCLTA(3) = PRCLTA(3)+PINITA(3)
18582 PRCLTA(4) = PRCLTA(4)+PINITA(4)
18586 * check momenta of residual nuclei
18588 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18590 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18592 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18594 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18596 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18597 **sr 19.12. changed to avoid output when used with phojet
18600 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18601 C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18602 C & CALL DT_EVTOUT(4)
18603 IF (IREJ1.GT.0) RETURN
18609 *===scn4ba=============================================================*
18611 CDECK ID>, DT_SCN4BA
18612 SUBROUTINE DT_SCN4BA
18614 ************************************************************************
18615 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
18616 * This version dated 12.12.95 is written by S. Roesler. *
18617 ************************************************************************
18619 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18622 PARAMETER ( LINP = 5 ,
18626 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18631 PARAMETER (NMXHKK=200000)
18633 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18634 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18635 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18636 * extended event history
18637 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18638 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18640 * particle properties (BAMJET index convention)
18642 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18643 & IICH(210),IIBAR(210),K1(210),K2(210)
18644 * properties of interacting particles
18645 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18646 * nuclear potential
18648 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18649 & EBINDP(2),EBINDN(2),EPOT(2,210),
18650 & ETACOU(2),ICOUL,LFERMI
18651 * treatment of residual nuclei: wounded nucleons
18652 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18653 * treatment of residual nuclei: 4-momenta
18654 LOGICAL LRCLPR,LRCLTA
18655 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18656 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18658 DIMENSION PLAB(2,5),PCMS(4)
18662 * get number of wounded nucleons
18679 * projectile nucleons wounded in primary interaction and in fzc
18680 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18684 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18685 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
18686 C IF (IP.GT.1) THEN
18688 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18691 * target nucleons wounded in primary interaction and in fzc
18692 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18696 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18697 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
18700 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18703 ELSEIF (ISTHKK(I).EQ.13) THEN
18705 ELSEIF (ISTHKK(I).EQ.14) THEN
18710 DO 11 I=NPOINT(4),NHKK
18711 * baryons which are unable to escape the nuclear potential of proj.
18712 IF (ISTHKK(I).EQ.15) THEN
18715 IF (IIBAR(IDBAM(I)).NE.0) THEN
18717 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18720 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18722 * baryons which are unable to escape the nuclear potential of targ.
18723 ELSEIF (ISTHKK(I).EQ.16) THEN
18726 IF (IIBAR(IDBAM(I)).NE.0) THEN
18728 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18731 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18736 * residual nuclei so far
18740 * ckeck for "residual nuclei" consisting of one nucleon only
18741 * treat it as final state particle
18742 IF (IRESP.EQ.1) THEN
18744 IST = ISTHKK(ISGLPR)
18745 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18746 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18747 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18748 IF (IST.EQ.13) THEN
18749 ISTHKK(ISGLPR) = 11
18753 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18754 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18755 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18756 NOBAM(NHKK) = NOBAM(ISGLPR)
18757 JDAHKK(1,ISGLPR) = NHKK
18759 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18762 IF (IREST.EQ.1) THEN
18764 IST = ISTHKK(ISGLTA)
18765 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18766 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18767 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18768 IF (IST.EQ.14) THEN
18769 ISTHKK(ISGLTA) = 12
18773 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18774 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18775 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18776 NOBAM(NHKK) = NOBAM(ISGLTA)
18777 JDAHKK(1,ISGLTA) = NHKK
18779 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18783 * get nuclear potential corresp. to the residual nucleus
18788 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18790 * baryons unable to escape the nuclear potential are treated as
18791 * excited nucleons (ISTHKK=15,16)
18792 DO 3 I=NPOINT(4),NHKK
18793 IF (ISTHKK(I).EQ.1) THEN
18795 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18796 * final state n and p not being outside of both nuclei are considered
18799 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
18800 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
18801 * Lorentz-trsf. into proj. rest sys. for those being inside proj.
18802 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18803 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18805 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18806 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18807 & (PLAB(1,4)+PLABT) ))
18808 EKIN = PLAB(1,4)-PLAB(1,5)
18809 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18810 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18812 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
18813 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
18814 * Lorentz-trsf. into targ. rest sys. for those being inside targ.
18815 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18816 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18818 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18819 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18820 & (PLAB(2,4)+PLABT) ))
18821 EKIN = PLAB(2,4)-PLAB(2,5)
18822 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18823 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18825 IF (PHKK(3,I).GE.ZERO) THEN
18827 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18830 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18832 IF (ISTHKK(I).NE.1) THEN
18835 PHKK(K,I) = PLAB(J,K)
18837 IF (ISTHKK(I).EQ.15) THEN
18839 IF (ID.EQ.1) NPCW = NPCW-1
18841 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18843 ELSEIF (ISTHKK(I).EQ.16) THEN
18845 IF (ID.EQ.1) NTCW = NTCW-1
18847 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18855 * again: get nuclear potential corresp. to the residual nucleus
18860 c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18861 cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18862 c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18864 c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18865 cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18866 c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18868 C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18869 C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18870 C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18871 C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18872 AFERP = FERMOD+0.1D0
18873 AFERT = FERMOD+0.1D0
18875 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18880 *===ficonf=============================================================*
18882 CDECK ID>, DT_FICONF
18883 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18885 ************************************************************************
18886 * Treatment of FInal CONFiguration including evaporation, fission and *
18887 * Fermi-break-up (for light nuclei only). *
18888 * Adopted from the original routine FINALE and extended to residual *
18889 * projectile nuclei. *
18890 * This version dated 12.12.95 is written by S. Roesler. *
18891 ************************************************************************
18893 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18896 PARAMETER ( LINP = 5 ,
18900 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18901 PARAMETER (ANGLGB=5.0D-16)
18905 PARAMETER (NMXHKK=200000)
18907 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18908 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18909 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18910 * extended event history
18911 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18912 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18914 * rejection counter
18915 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18916 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18917 & IREXCI(3),IRDIFF(2),IRINC
18918 * central particle production, impact parameter biasing
18919 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18920 * particle properties (BAMJET index convention)
18922 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18923 & IICH(210),IIBAR(210),K1(210),K2(210)
18924 * treatment of residual nuclei: 4-momenta
18925 LOGICAL LRCLPR,LRCLTA
18926 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18927 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18928 * treatment of residual nuclei: properties of residual nuclei
18929 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18930 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18931 & NTOTFI(2),NPROFI(2)
18932 * statistics: residual nuclei
18933 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18934 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18935 & NINCST(2,4),NINCEV(2),
18936 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18937 & NRESPB(2),NRESCH(2),NRESEV(4),
18938 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18940 * flags for input different options
18941 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18942 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18943 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18948 PARAMETER ( EMVGEV = 1.0 D-03 )
18949 PARAMETER ( AMUGEV = 0.93149432 D+00 )
18950 PARAMETER ( AMPRTN = 0.93827231 D+00 )
18951 PARAMETER ( AMNTRN = 0.93956563 D+00 )
18952 PARAMETER ( AMELCT = 0.51099906 D-03 )
18953 PARAMETER ( ELCCGS = 4.8032068 D-10 )
18954 PARAMETER ( ELCMKS = 1.60217733 D-19 )
18955 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
18957 PARAMETER ( HLFHLF = 0.5D+00 )
18958 PARAMETER ( FERTHO = 14.33 D-09 )
18959 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18960 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18961 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18967 COMMON /DTEVNO/ NEVENT,ICASCA
18969 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18970 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18971 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18973 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18974 DATA EXC,NEXC /520*ZERO,520*0/
18975 DATA EXPNUC /4.0D-3,4.0D-3/
18981 * skip residual nucleus treatment if not requested or in case
18982 * of central collisions
18983 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19010 * number of final state particles
19011 IF (ABS(ISTHKK(I)).EQ.1) THEN
19016 * properties of remaining nucleon configurations
19018 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19019 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19021 IF (MO1(KF).EQ.0) MO1(KF) = I
19023 * position of residual nucleus = average position of nucleons
19025 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19026 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19028 * total number of particles contributing to each residual nucleus
19029 NTOT(KF) = NTOT(KF)+1
19032 * total charge of residual nuclei
19033 NQ(KF) = NQ(KF)+IICH(IDTMP)
19034 * number of protons
19035 IF (IDHKK(I).EQ.2212) THEN
19036 NPRO(KF) = NPRO(KF)+1
19037 * number of neutrons
19038 ELSEIF (IDHKK(I).EQ.2112) THEN
19041 * number of baryons other than n, p
19042 IF (IIBAR(IDTMP).EQ.1) THEN
19044 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19046 * any other mesons (status set to 1)
19047 C WRITE(LOUT,1002) KF,IDTMP
19048 C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
19049 C & ' containing meson ',I4,', status set to 1')
19052 IDXTMP = IDXPAR(KF)
19053 NTOT(KF) = NTOT(KF)-1
19057 IDXPAR(KF) = IDXTMP
19061 * reject elastic events (def: one final state particle = projectile)
19062 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19063 IREXCI(3) = IREXCI(3)+1
19068 * check if one nucleus disappeared..
19069 C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19071 C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19074 C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19076 C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19085 * get the average of the nucleon positions
19086 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19087 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19088 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19089 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19091 * mass number and charge of residual nuclei
19092 AIF(I) = DBLE(NTOT(I))
19093 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
19094 IF (NTOT(I).GT.1) THEN
19095 * masses of residual nuclei in ground state
19097 C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
19098 AMRCL0(I) = AIF(I)*AMUC12
19099 & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
19101 * masses of residual nuclei
19102 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
19103 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
19104 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
19105 IF (AMRCL(I).LE.ZERO) THEN
19106 IF (IOULEV(3).GT.0)
19107 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
19109 1000 FORMAT(1X,'warning! negative excitation energy',/,
19113 IF (NLOOP.LE.500) THEN
19116 IREXCI(2) = IREXCI(2)+1
19119 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
19122 C WRITE(6,*) NEVHKK,I,NTOT(1),NTOT(2),AMRCL(I),AMRCL0(I)
19125 C AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
19126 M = MIN(NTOT(I),260)
19127 IF (NEXC(I,M).GT.0) THEN
19128 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19132 IF (M.GE.INUC(I)) THEN
19133 AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
19135 IF (NEXC(I,M).GT.0) THEN
19136 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19143 EEXC(I) = AMRCL(I)-AMRCL0(I)
19145 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19146 IF (IOULEV(3).GT.0)
19147 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19148 1004 FORMAT(1X,'warning! too high excitation energy',/,
19149 & I4,1P,2E15.4,3I5)
19152 IF (NLOOP.LE.500) THEN
19155 IREXCI(2) = IREXCI(2)+1
19159 * excitation energies of residual nuclei
19160 EEXC(I) = AMRCL(I)-AMRCL0(I)
19161 IF (ICASCA.EQ.0) THEN
19163 C EXPNUC(I) = EEXC(I)/DBLE(NTOT(I))
19164 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19165 M = MIN(NTOT(I),260)
19166 EXC(I,M) = EXC(I,M)+EEXC(I)
19167 NEXC(I,M) = NEXC(I,M)+1
19170 ELSEIF (NTOT(I).EQ.1) THEN
19172 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
19182 PRCLPR(5) = AMRCL(1)
19183 PRCLTA(5) = AMRCL(2)
19185 IF (ICOR.GT.0) THEN
19186 IF (INORCL.EQ.0) THEN
19187 * one or both residual nuclei consist of one nucleon only, transform
19188 * this nucleon on mass shell
19190 P1IN(K) = PRCL(1,K)
19191 P2IN(K) = PRCL(2,K)
19195 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19196 IF (IREJ1.GT.0) THEN
19197 WRITE(LOUT,*) 'ficonf-mashel rejection'
19201 PRCL(1,K) = P1OUT(K)
19202 PRCL(2,K) = P2OUT(K)
19203 PRCLPR(K) = P1OUT(K)
19204 PRCLTA(K) = P2OUT(K)
19206 PRCLPR(5) = AMRCL(1)
19207 PRCLTA(5) = AMRCL(2)
19209 IF (IOULEV(3).GT.0)
19210 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19211 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19212 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19213 & AMRCL(2),AMRCL(2)-AMRCL0(2)
19214 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
19215 & ' correction',/,11X,'at event',I8,
19216 & ', nucleon config. 1:',2I4,' 2:',2I4,
19218 IF (NLOOP.LE.500) THEN
19221 IREXCI(1) = IREXCI(1)+1
19227 C IF (NRESEV(1).NE.NEVHKK) THEN
19228 C NRESEV(1) = NEVHKK
19229 C NRESEV(2) = NRESEV(2)+1
19231 NRESEV(2) = NRESEV(2)+1
19233 EXCDPM(I) = EXCDPM(I)+EEXC(I)
19234 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19235 NRESTO(I) = NRESTO(I)+NTOT(I)
19236 NRESPR(I) = NRESPR(I)+NPRO(I)
19237 NRESNU(I) = NRESNU(I)+NN(I)
19238 NRESBA(I) = NRESBA(I)+NH(I)
19239 NRESPB(I) = NRESPB(I)+NHPOS(I)
19240 NRESCH(I) = NRESCH(I)+NQ(I)
19246 * initialize evaporation counter
19249 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19250 & (EEXC(I).GT.ZERO)) THEN
19251 * put residual nuclei into DTEVT1
19253 JMASS = INT( AIF(I))
19254 JCHAR = INT(AIZF(I))
19255 * the following patch is required to transmit the correct excitation
19257 IF (ITRSPT.EQ.1) THEN
19259 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19261 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19263 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19266 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19267 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19272 VHKK(J,NHKK) = VRCL(I,J)
19273 WHKK(J,NHKK) = WRCL(I,J)
19275 * interface to evaporation module - fill final residual nucleus into
19277 * fill resnuc only if code is not used as event generator in Fluka
19278 IF (ITRSPT.NE.1) THEN
19282 IBRES = NPRO(I)+NN(I)+NH(I)
19283 ICRES = NPRO(I)+NHPOS(I)
19286 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
19287 * ground state mass of the residual nucleus (should be equal to AM0T)
19290 AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
19294 * kinetic energy of residual nucleus
19295 TVRECL = PRCL(I,4)-AMRCL(I)
19296 * excitation energy of residual nucleus
19299 PTRES = SQRT(ABS(TVRECL*(TVRECL+
19300 & 2.0D0*(AMMRES+TVCMS))))
19301 IF (PTOLD.LT.ANGLGB) THEN
19302 CALL DT_RACO(PXRES,PYRES,PZRES)
19305 PXRES = PXRES*PTRES/PTOLD
19306 PYRES = PYRES*PTRES/PTOLD
19307 PZRES = PZRES*PTRES/PTOLD
19316 * put evaporated particles and residual nuclei to DTEVT1
19318 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19321 EXCEVA(I) = EXCEVA(I)+EXCITF
19328 C9998 IREXCI(1) = IREXCI(1)+1
19337 *====eva2he============================================================*
19339 CDECK ID>, DT_EVA2HE
19340 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19342 ************************************************************************
19343 * Interface between common's of evaporation module (FKFINU,FKFHVY) *
19345 * MO DTEVT1-index of "mother" (residual) nucleus before evap. *
19346 * EEXCF exitation energy of residual nucleus after evaporation *
19347 * IRCL = 1 projectile residual nucleus *
19348 * = 2 target residual nucleus *
19349 * This version dated 19.04.95 is written by S. Roesler. *
19350 ************************************************************************
19352 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19355 PARAMETER ( LINP = 5 ,
19359 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19363 PARAMETER (NMXHKK=200000)
19365 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19366 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19367 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19368 * Note: DTEVT2 - special use for heavy fragments !
19369 * (IDRES(I) = mass number, IDXRES(I) = charge)
19370 * extended event history
19371 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19372 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19374 * particle properties (BAMJET index convention)
19376 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19377 & IICH(210),IIBAR(210),K1(210),K2(210)
19378 * flags for input different options
19379 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19380 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19381 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19382 * statistics: residual nuclei
19383 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19384 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19385 & NINCST(2,4),NINCEV(2),
19386 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19387 & NRESPB(2),NRESCH(2),NRESEV(4),
19388 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19390 * treatment of residual nuclei: properties of residual nuclei
19391 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19392 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19393 & NTOTFI(2),NPROFI(2)
19400 DIMENSION IPTOKP(39)
19401 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19402 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19403 & 100, 101, 97, 102, 98, 103, 109, 115 /
19407 * skip if evaporation package is not included
19408 IF (.NOT.LEVAPO) RETURN
19411 IF (NRESEV(3).NE.NEVHKK) THEN
19413 NRESEV(4) = NRESEV(4)+1
19417 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19419 * mass number/charge of residual nucleus before evaporation
19423 * protons/neutrons/gammas
19428 ID = IPTOKP(KPART(I))
19429 IDPDG = IDT_IPDGHA(ID)
19430 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19431 & (2.0D0*MAX(TKI(I),TINY10))
19432 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19433 WRITE(LOUT,1000) ID,AM,AAM(ID)
19434 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
19435 & 'particle',I3,2E10.3)
19438 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19440 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19441 IBTOT = IBTOT-IIBAR(ID)
19442 IZTOT = IZTOT-IICH(ID)
19447 PX = CXHEAV(I)*PHEAVY(I)
19448 PY = CYHEAV(I)*PHEAVY(I)
19449 PZ = CZHEAV(I)*PHEAVY(I)
19451 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19452 & (2.0D0*MAX(TKHEAV(I),TINY10))
19454 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19455 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19457 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19458 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19459 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19462 IF (IBRES.GT.0) THEN
19463 * residual nucleus after evaporation
19465 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19470 NTOTFI(IRCL) = IBRES
19471 NPROFI(IRCL) = ICRES
19472 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19473 IBTOT = IBTOT-IBRES
19474 IZTOT = IZTOT-ICRES
19476 * count events with fission
19477 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19478 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19480 * energy-momentum conservation check
19481 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19482 C IF (IREJ.GT.0) THEN
19483 C CALL DT_EVTOUT(4)
19484 C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19486 * baryon-number/charge conservation check
19487 IF (IBTOT+IZTOT.NE.0) THEN
19488 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19489 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
19490 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
19496 *===ebind==============================================================*
19498 CDECK ID>, DT_EBIND
19499 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19501 ************************************************************************
19502 * Binding energy for nuclei. *
19503 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
19505 * IZ atomic number *
19506 * This version dated 5.5.95 is updated by S. Roesler. *
19507 ************************************************************************
19509 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19512 PARAMETER ( LINP = 5 ,
19516 PARAMETER (ZERO=0.0D0)
19518 DATA A1, A2, A3, A4, A5
19519 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19521 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19522 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
19527 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19528 & -A4*(IA-2*IZ)**2/AA
19529 IF (MOD(IA,2).EQ.1) THEN
19531 ELSEIF (MOD(IZ,2).EQ.1) THEN
19536 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19541 ************************************************************************
19543 * DPMJET 3.0: cross section routines *
19545 ************************************************************************
19548 * SUBROUTINE DT_SHNDIF
19549 * diffractive cross sections (all energies)
19550 * SUBROUTINE DT_PHOXS
19551 * total and inel. cross sections from PHOJET interpol. tables
19552 * SUBROUTINE DT_XSHN
19553 * total and el. cross sections for all energies
19554 * SUBROUTINE DT_SIHNAB
19555 * pion 2-nucleon absorption cross sections
19556 * SUBROUTINE DT_SIGEMU
19557 * cross section for target "compounds"
19558 * SUBROUTINE DT_SIGGA
19559 * photon nucleus cross sections
19560 * SUBROUTINE DT_SIGGAT
19561 * photon nucleus cross sections from tables
19562 * SUBROUTINE DT_SANO
19563 * anomalous hard photon-nucleon cross sections from tables
19564 * SUBROUTINE DT_SIGGP
19565 * photon nucleon cross sections
19566 * SUBROUTINE DT_SIGVEL
19567 * quasi-elastic vector meson prod. cross sections
19568 * DOUBLE PRECISION FUNCTION DT_SIGVP
19570 * DOUBLE PRECISION FUNCTION DT_RRM2
19571 * DOUBLE PRECISION FUNCTION DT_RM2
19572 * DOUBLE PRECISION FUNCTION DT_SAM2
19573 * SUBROUTINE DT_CKMT
19574 * SUBROUTINE DT_CKMTX
19575 * SUBROUTINE DT_PDF0
19576 * SUBROUTINE DT_CKMTQ0
19577 * SUBROUTINE DT_CKMTDE
19578 * SUBROUTINE DT_CKMTPR
19579 * FUNCTION DT_CKMTFF
19581 * SUBROUTINE DT_FLUINI
19582 * total nucleon cross section fluctuation treatment
19584 * SUBROUTINE DT_SIGTBL
19585 * pre-tabulation of low-energy elastic x-sec. using SIHNEL
19586 * SUBROUTINE DT_XSTABL
19591 *===shndif===============================================================*
19593 CDECK ID>, DT_SHNDIF
19594 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
19596 **********************************************************************
19597 * Single diffractive hadron-nucleon cross sections *
19598 * S.Roesler 14/1/93 *
19600 * The cross sections are calculated from extrapolated single *
19601 * diffractive antiproton-proton cross sections (DTUJET92) using *
19602 * scaling relations between total and single diffractive cross *
19604 **********************************************************************
19606 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19608 PARAMETER (ZERO=0.0D0)
19610 * particle properties (BAMJET index convention)
19612 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19613 & IICH(210),IIBAR(210),K1(210),K2(210)
19615 CSD1 = 4.201483727D0
19616 CSD4 = -0.4763103556D-02
19617 CSD5 = 0.4324148297D0
19619 CHMSD1 = 0.8519297242D0
19620 CHMSD4 = -0.1443076599D-01
19621 CHMSD5 = 0.4014954567D0
19623 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
19624 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
19626 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
19627 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
19628 FRAC = SHMSD/SDIAPP
19630 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
19631 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
19632 & 10, 10, 20, 20, 20) KPROJ
19635 *---------------------------- p - p , n - p , sigma0+- - p ,
19637 CSD1 = 6.004476070D0
19638 CSD4 = -0.1257784606D-03
19639 CSD5 = 0.2447335720D0
19640 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
19641 SIGDIH = FRAC*SIGDIF
19648 C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
19650 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
19653 C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
19654 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
19656 SIGDIH = FRAC*SIGDIF
19660 *-------------------------- leptons..
19666 *===phoxs================================================================*
19668 CDECK ID>, DT_PHOXS
19669 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
19671 ************************************************************************
19672 * Total/inelastic proton-nucleon cross sections taken from PHOJET- *
19673 * interpolation tables. *
19674 * This version dated 05.11.97 is written by S. Roesler *
19675 ************************************************************************
19677 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19680 PARAMETER ( LINP = 5 ,
19684 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
19685 PARAMETER (TWOPI = 6.283185307179586454D+00,
19687 & GEV2MB = 0.38938D0)
19690 DATA LFIRST /.TRUE./
19692 * nucleon-nucleon event-generator
19695 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
19696 * particle properties (BAMJET index convention)
19698 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19699 & IICH(210),IIBAR(210),K1(210),K2(210)
19702 C PARAMETER (IEETAB=10)
19703 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
19705 C energy-interpolation table
19707 PARAMETER ( IEETA2 = 20 )
19709 DOUBLE PRECISION SIGTAB,SIGECM
19710 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
19713 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
19714 WRITE(LOUT,*) MCGENE
19715 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
19719 IF (ECM.LE.ZERO) THEN
19720 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
19721 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
19724 IF (MODE.EQ.1) THEN
19729 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
19731 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
19732 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
19738 IF(ECM.LE.SIGECM(IP,1)) THEN
19741 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
19743 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
19750 WRITE(LOUT,'(/1X,A,2E12.3)')
19751 & 'PHOXS: warning! energy above initialization limit (',
19752 & ECM,SIGECM(IP,ISIMAX)
19759 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
19760 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
19762 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
19763 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
19764 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
19765 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
19766 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
19772 *===xshn===============================================================*
19775 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
19777 ************************************************************************
19778 * Total and elastic hadron-nucleon cross section. *
19779 * Below 500GeV cross sections are based on the '98 data compilation *
19780 * of the PDG. At higher energies PHOJET results are used (patched to *
19781 * the low energy data at 500GeV). *
19782 * IP projectile index (BAMJET numbering scheme) *
19783 * (should be in the range 1..25) *
19784 * IT target index (BAMJET numbering scheme) *
19785 * (1 = proton, 8 = neutron) *
19786 * PL laboratory momentum *
19787 * ECM cm. energy (ignored if PL>0) *
19788 * STOT total cross section *
19789 * SELA elastic cross section *
19790 * Last change: 24.4.99 by S. Roesler *
19791 ************************************************************************
19793 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19796 PARAMETER ( LINP = 5 ,
19800 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
19802 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
19803 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
19804 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
19807 * particle properties (BAMJET index convention)
19809 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19810 & IICH(210),IIBAR(210),K1(210),K2(210)
19811 * nucleon-nucleon event-generator
19814 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
19816 C PARAMETER (IEETAB=10)
19817 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
19819 C energy-interpolation table
19821 PARAMETER ( IEETA2 = 20 )
19823 DOUBLE PRECISION SIGTAB,SIGECM
19824 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
19826 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
19827 DIMENSION IDXDAT(25,2)
19830 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
19831 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
19832 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
19833 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
19834 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
19835 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
19836 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
19838 * total cross sections:
19840 DATA (ASIGTO(1,K),K=1,NPOINT) /
19841 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
19842 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
19843 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
19844 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
19845 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
19846 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
19847 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
19849 DATA (ASIGTO(2,K),K=1,NPOINT) /
19850 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
19851 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
19852 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
19853 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
19854 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
19855 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
19856 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
19858 DATA (ASIGTO(3,K),K=1,NPOINT) /
19859 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
19860 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
19861 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
19862 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
19863 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
19864 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
19865 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
19867 DATA (ASIGTO(4,K),K=1,NPOINT) /
19868 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
19869 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
19870 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
19871 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
19872 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
19873 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
19874 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
19876 DATA (ASIGTO(5,K),K=1,NPOINT) /
19877 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
19878 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
19879 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
19880 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
19881 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
19882 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
19883 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
19885 DATA (ASIGTO(6,K),K=1,NPOINT) /
19886 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
19887 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
19888 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
19889 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
19890 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
19891 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
19892 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
19894 DATA (ASIGTO(7,K),K=1,NPOINT) /
19895 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
19896 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
19897 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
19898 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
19899 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
19900 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
19901 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
19903 DATA (ASIGTO(8,K),K=1,NPOINT) /
19904 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
19905 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
19906 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
19907 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
19908 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
19909 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
19910 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
19912 DATA (ASIGTO(9,K),K=1,NPOINT) /
19913 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
19914 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
19915 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
19916 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
19917 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
19918 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
19919 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
19921 DATA (ASIGTO(10,K),K=1,NPOINT) /
19922 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
19923 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
19924 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
19925 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
19926 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
19927 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
19928 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
19930 * elastic cross sections:
19932 DATA (ASIGEL(1,K),K=1,NPOINT) /
19933 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
19934 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
19935 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
19936 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
19937 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
19938 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
19939 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
19941 DATA (ASIGEL(2,K),K=1,NPOINT) /
19942 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
19943 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
19944 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
19945 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
19946 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
19947 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
19948 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
19950 DATA (ASIGEL(3,K),K=1,NPOINT) /
19951 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
19952 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
19953 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
19954 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
19955 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
19956 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
19957 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
19959 DATA (ASIGEL(4,K),K=1,NPOINT) /
19960 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
19961 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
19962 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
19963 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
19964 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
19965 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
19966 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
19968 DATA (ASIGEL(5,K),K=1,NPOINT) /
19969 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
19970 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
19971 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
19972 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
19973 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
19974 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
19975 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
19977 DATA (ASIGEL(6,K),K=1,NPOINT) /
19978 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
19979 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
19980 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
19981 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
19982 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
19983 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
19984 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
19986 DATA (ASIGEL(7,K),K=1,NPOINT) /
19987 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
19988 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
19989 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
19990 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
19991 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
19992 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
19993 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
19995 DATA (ASIGEL(8,K),K=1,NPOINT) /
19996 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
19997 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
19998 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
19999 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
20000 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
20001 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
20002 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
20004 DATA (ASIGEL(9,K),K=1,NPOINT) /
20005 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
20006 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
20007 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
20008 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
20009 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
20010 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
20011 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
20013 DATA (ASIGEL(10,K),K=1,NPOINT) /
20014 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
20015 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
20016 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
20017 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
20018 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
20019 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
20020 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
20022 DATA (IDXDAT(K,1),K=1,25) /
20023 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
20025 DATA (IDXDAT(K,2),K=1,25) /
20026 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
20029 DATA LFIRST /.TRUE./
20032 APLABL = LOG10(PLABLO)
20033 APLABH = LOG10(PLABHI)
20034 APTHRE = LOG10(PTHRE)
20035 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
20036 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
20039 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
20040 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
20041 IF (MCGENE.EQ.2) THEN
20042 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
20043 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
20045 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
20048 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
20050 PHOSEL = PHOSTO-PHOSIN
20051 APHOST = LOG10(PHOSTO)
20052 APHOSE = LOG10(PHOSEL)
20059 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
20060 WRITE(LOUT,1000) IP,IT
20061 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
20062 & 'proj/target',2I4)
20066 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
20067 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
20068 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
20069 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
20070 WRITE(LOUT,1001) PLAB,ECMS
20071 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
20075 * index of spectrum
20078 IF (AAM(IP).GT.ZERO) THEN
20079 IF (ABS(IIBAR(IP)).GT.0) THEN
20089 IF (IT.EQ.8) IDXT = 2
20090 IDXS = IDXDAT(IDXP,IDXT)
20091 IF (IDXS.EQ.0) RETURN
20093 * compute momentum bin indices
20094 IF (PLAB.LT.PLABLO) THEN
20097 ELSEIF (PLAB.GE.PLABHI) THEN
20101 APLAB = LOG10(PLAB)
20102 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
20103 IDX0 = INT((APLAB-APLABL)/ADP1)+1
20104 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
20105 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
20110 * interpolate cross section
20111 IF (IDXS.GT.10) THEN
20113 IDXS2 = IDXS-10*IDXS1
20114 IF (IDX0.EQ.IDX1) THEN
20115 IF (IDX0.EQ.1) THEN
20116 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
20117 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
20120 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
20121 PHOSEL = PHOSTO-PHOSIN
20122 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
20123 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
20124 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
20125 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
20126 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
20127 ASELA = 0.5D0*(ASELA1+ASELA2)
20130 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
20131 ASTOT1 = ASIGTO(IDXS1,IDX0)+
20132 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
20133 ASTOT2 = ASIGTO(IDXS2,IDX0)+
20134 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
20135 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
20136 ASELA1 = ASIGEL(IDXS1,IDX0)+
20137 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
20138 ASELA2 = ASIGEL(IDXS2,IDX0)+
20139 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
20140 ASELA = 0.5D0*(ASELA1+ASELA2)
20143 IF (IDX0.EQ.IDX1) THEN
20144 IF (IDX0.EQ.1) THEN
20145 ASTOT = ASIGTO(IDXS,IDX0)
20146 ASELA = ASIGEL(IDXS,IDX0)
20149 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
20150 PHOSEL = PHOSTO-PHOSIN
20151 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
20152 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
20155 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
20156 ASTOT = ASIGTO(IDXS,IDX0)+
20157 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
20158 ASELA = ASIGEL(IDXS,IDX0)+
20159 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
20162 STOT = 10.0D0**ASTOT
20163 SELA = 10.0D0**ASELA
20168 *===sihnab===============================================================*
20170 CDECK ID>, DT_SIHNAB
20171 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
20173 **********************************************************************
20174 * Pion 2-nucleon absorption cross sections. *
20175 * (sigma_tot for pi+ d --> p p, pi- d --> n n *
20176 * taken from Ritchie PRC 28 (1983) 926 ) *
20177 * This version dated 18.05.96 is written by S. Roesler *
20178 **********************************************************************
20180 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20182 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
20183 PARAMETER (AMPR = 938.0D0,
20193 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
20194 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
20196 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
20197 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
20198 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
20199 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
20200 * approximate 3N-abs., I=1-abs. etc.
20201 SIGABS = SIGABS/0.40D0
20202 * pi0-absorption (rough approximation!!)
20203 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
20208 *===sigemu=============================================================*
20210 CDECK ID>, DT_SIGEMU
20211 SUBROUTINE DT_SIGEMU
20213 ************************************************************************
20214 * Combined cross section for target compounds. *
20215 * This version dated 6.4.98 is written by S. Roesler *
20216 ************************************************************************
20218 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20221 PARAMETER ( LINP = 5 ,
20225 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
20226 & OHALF=0.5D0,ONE=1.0D0)
20228 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20230 * Glauber formalism: cross sections
20231 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
20232 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
20233 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
20234 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
20235 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
20236 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
20237 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
20238 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
20239 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
20240 & BSLOPE,NEBINI,NQBINI
20241 * emulsion treatment
20242 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
20244 * nucleon-nucleon event-generator
20247 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20249 IF (MCGENE.NE.4) THEN
20250 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
20251 WRITE(LOUT,'(15X,A)') '-----------------------'
20271 IF (NCOMPO.GT.0) THEN
20273 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
20274 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
20275 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
20276 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
20277 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
20278 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
20279 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
20280 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
20281 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
20282 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
20283 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
20284 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
20285 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
20286 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
20287 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
20288 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
20290 ERRTOT = SQRT(ERRTOT)
20291 ERRELA = SQRT(ERRELA)
20292 ERRQEP = SQRT(ERRQEP)
20293 ERRQET = SQRT(ERRQET)
20294 ERRQE2 = SQRT(ERRQE2)
20295 ERRPRO = SQRT(ERRPRO)
20296 ERRDEL = SQRT(ERRDEL)
20297 ERRDQE = SQRT(ERRDQE)
20299 SIGTOT = XSTOT(IE,IQ,1)
20300 SIGELA = XSELA(IE,IQ,1)
20301 SIGQEP = XSQEP(IE,IQ,1)
20302 SIGQET = XSQET(IE,IQ,1)
20303 SIGQE2 = XSQE2(IE,IQ,1)
20304 SIGPRO = XSPRO(IE,IQ,1)
20305 SIGDEL = XSDEL(IE,IQ,1)
20306 SIGDQE = XSDQE(IE,IQ,1)
20307 ERRTOT = XETOT(IE,IQ,1)
20308 ERRELA = XEELA(IE,IQ,1)
20309 ERRQEP = XEQEP(IE,IQ,1)
20310 ERRQET = XEQET(IE,IQ,1)
20311 ERRQE2 = XEQE2(IE,IQ,1)
20312 ERRPRO = XEPRO(IE,IQ,1)
20313 ERRDEL = XEDEL(IE,IQ,1)
20314 ERRDQE = XEDQE(IE,IQ,1)
20316 IF (MCGENE.NE.4) THEN
20317 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
20318 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
20319 WRITE(LOUT,1001) SIGTOT,ERRTOT
20320 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
20321 WRITE(LOUT,1002) SIGELA,ERRELA
20322 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
20323 WRITE(LOUT,1003) SIGQEP,ERRQEP
20324 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
20326 WRITE(LOUT,1004) SIGQET,ERRQET
20327 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
20329 WRITE(LOUT,1005) SIGQE2,ERRQE2
20330 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
20331 & ' +-',F11.5,' mb')
20332 WRITE(LOUT,1006) SIGPRO,ERRPRO
20333 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
20334 WRITE(LOUT,1007) SIGDEL,ERRDEL
20335 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
20336 WRITE(LOUT,1008) SIGDQE,ERRDQE
20337 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
20346 *===sigga==============================================================*
20348 CDECK ID>, DT_SIGGA
20349 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
20351 ************************************************************************
20352 * Total/inelastic photon-nucleus cross sections. *
20353 * !!!! Overwrites SHMAKI-initialization. Do not use it during *
20354 * production runs !!!! *
20355 * This version dated 27.03.96 is written by S. Roesler *
20356 ************************************************************************
20358 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20361 PARAMETER ( LINP = 5 ,
20365 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
20366 & OHALF=0.5D0,ONE=1.0D0)
20367 PARAMETER (AMPROT = 0.938D0)
20369 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20371 * Glauber formalism: cross sections
20372 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
20373 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
20374 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
20375 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
20376 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
20377 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
20378 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
20379 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
20380 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
20381 & BSLOPE,NEBINI,NQBINI
20388 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20389 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
20390 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
20391 STOT = XSTOT(1,1,1)
20392 ETOT = XETOT(1,1,1)
20399 *===siggat=============================================================*
20401 CDECK ID>, DT_SIGGAT
20402 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
20404 ************************************************************************
20405 * Total/inelastic photon-nucleus cross sections. *
20406 * Uses pre-tabulated cross section. *
20407 * This version dated 29.07.96 is written by S. Roesler *
20408 ************************************************************************
20410 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20413 PARAMETER ( LINP = 5 ,
20417 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
20418 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20420 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20422 * Glauber formalism: cross sections
20423 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
20424 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
20425 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
20426 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
20427 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
20428 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
20429 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
20430 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
20431 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
20432 & BSLOPE,NEBINI,NQBINI
20438 IF (NEBINI.GT.1) THEN
20439 IF (ECMI.GE.ECMNN(NEBINI)) THEN
20443 ELSEIF (ECMI.GT.ECMNN(1)) THEN
20445 IF (ECMI.LT.ECMNN(I)) THEN
20448 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
20458 IF (NQBINI.GT.1) THEN
20459 IF (Q2I.GE.Q2G(NQBINI)) THEN
20463 ELSEIF (Q2I.GT.Q2G(1)) THEN
20465 IF (Q2I.LT.Q2G(I)) THEN
20468 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
20469 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
20470 C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
20478 STOT = XSTOT(I1,J1,NTARG)+
20479 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
20480 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
20481 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
20482 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
20487 *===sigano=============================================================*
20490 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
20492 ************************************************************************
20493 * This version dated 31.07.96 is written by S. Roesler *
20494 ************************************************************************
20496 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20499 PARAMETER ( LINP = 5 ,
20503 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
20504 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20507 * VDM parameter for photon-nucleus interactions
20508 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20509 * properties of interacting particles
20510 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
20512 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
20514 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
20515 & 0.100D+04,0.200D+04,0.500D+04
20517 * fixed cut (3 GeV/c)
20519 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
20520 & 0.062D+00,0.054D+00,0.042D+00
20523 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
20524 & 3.3086D-01,7.6255D-01,2.1319D+00
20526 * running cut (based on obsolete Phojet-caluclations, bugs..)
20528 C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
20529 C & 0.167E+00,0.150E+00,0.131E+00
20532 C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
20533 C & 2.5736E-01,4.5593E-01,8.2550E-01
20537 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
20541 IF (ECM.GE.ECMANO(NE)) THEN
20544 ELSEIF (ECM.GT.ECMANO(1)) THEN
20546 IF (ECM.LT.ECMANO(IE)) THEN
20549 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
20555 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
20556 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
20557 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
20558 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
20564 *===siggp==============================================================*
20566 CDECK ID>, DT_SIGGP
20567 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
20569 ************************************************************************
20570 * Total/inelastic photon-nucleon cross sections. *
20571 * This version dated 30.04.96 is written by S. Roesler *
20572 ************************************************************************
20574 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20577 PARAMETER ( LINP = 5 ,
20581 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20582 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20584 & GEV2MB = 0.38938D0,
20585 & ALPHEM = ONE/137.0D0)
20587 * particle properties (BAMJET index convention)
20589 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20590 & IICH(210),IIBAR(210),K1(210),K2(210)
20591 * VDM parameter for photon-nucleus interactions
20592 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20595 C CHARACTER*8 MDLNA
20596 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
20597 C PARAMETER (IEETAB=10)
20598 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20600 C model switches and parameters
20602 INTEGER ISWMDL,IPAMDL
20603 DOUBLE PRECISION PARMDL
20604 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20605 C energy-interpolation table
20607 PARAMETER ( IEETA2 = 20 )
20609 DOUBLE PRECISION SIGTAB,SIGECM
20610 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20613 C PARAMETER (NPOINT=80)
20614 PARAMETER (NPOINT=16)
20615 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
20622 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20623 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
20627 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20629 X = Q2/(W2+Q2-AAM(1)**2)
20631 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
20632 X = Q2/(W2+Q2-AAM(1)**2)
20633 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20634 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
20635 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
20636 W2 = Q2*(ONE-X)/X+AAM(1)**2
20638 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
20643 IF (MODEGA.EQ.1) THEN
20645 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
20649 C ALLMF2 = PHO_ALLM97(Q2,W)
20651 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
20652 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
20655 ELSEIF (MODEGA.EQ.2) THEN
20656 IF (INTRGE(1).EQ.1) THEN
20657 AMLO2 = (3.0D0*AAM(13))**2
20658 ELSEIF (INTRGE(1).EQ.2) THEN
20663 IF (INTRGE(2).EQ.1) THEN
20665 ELSEIF (INTRGE(2).EQ.2) THEN
20670 AMHI20 = (ECM-AAM(1))**2
20671 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
20672 XAMLO = LOG( AMLO2+Q2 )
20673 XAMHI = LOG( AMHI2+Q2 )
20675 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
20678 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
20683 AM2 = EXP(ABSZX(J))-Q2
20684 IF (AM2.LT.16.0D0) THEN
20686 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
20691 C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
20692 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
20693 & * (ONE+EPSPOL*Q2/AM2)
20694 SUM = SUM+WEIGHT(J)*FAC
20697 SDIR = DT_SIGVP(X,Q2)
20698 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
20699 SDIR = SDIR/(0.588D0+RL2+Q2)
20700 C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
20701 ELSEIF (MODEGA.EQ.3) THEN
20702 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
20703 ELSEIF (MODEGA.EQ.4) THEN
20704 * load cross sections from PHOJET interpolation table
20706 IF(ECM.LE.SIGECM(IP,1)) THEN
20709 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20711 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
20717 WRITE(LOUT,'(/1X,A,2E12.3)')
20718 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
20723 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20724 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20726 * cross section dependence on photon virtuality
20729 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
20730 & /(1.D0+Q2/PARMDL(30+I))**2
20732 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
20736 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20737 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20738 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
20742 SDIR = SDIR/(FSUP1*FSUP2)
20751 *===sigvel=============================================================*
20753 CDECK ID>, DT_SIGVEL
20754 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
20756 ************************************************************************
20757 * Cross section for elastic vector meson production *
20758 * This version dated 10.05.96 is written by S. Roesler *
20759 ************************************************************************
20761 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20764 PARAMETER ( LINP = 5 ,
20768 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20769 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20771 & GEV2MB = 0.38938D0,
20772 & ALPHEM = ONE/137.0D0)
20774 * particle properties (BAMJET index convention)
20776 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20777 & IICH(210),IIBAR(210),K1(210),K2(210)
20778 * VDM parameter for photon-nucleus interactions
20779 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20782 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20783 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
20787 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20789 X = Q2/(W2+Q2-AAM(1)**2)
20791 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
20792 X = Q2/(W2+Q2-AAM(1)**2)
20793 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20794 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
20795 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
20796 W2 = Q2*(ONE-X)/X+AAM(1)**2
20798 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
20806 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
20807 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
20809 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
20810 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
20812 IF (IDXV.EQ.33) THEN
20817 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
20819 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
20820 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
20825 *===sigvp==============================================================*
20827 CDECK ID>, DT_SIGVP
20828 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
20830 ************************************************************************
20832 ************************************************************************
20834 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20837 PARAMETER ( LINP = 5 ,
20841 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20842 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20844 & GEV2MB = 0.38938D0,
20845 & AMPROT = 0.938D0,
20846 & ALPHEM = ONE/137.0D0)
20847 * VDM parameter for photon-nucleus interactions
20848 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20852 IF (XI.LE.ZERO) X = 0.0001D0
20853 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
20855 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
20858 IF (MODEGA.EQ.1) THEN
20859 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
20863 C ALLMF2 = PHO_ALLM97(Q2,W)
20865 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
20866 C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
20867 C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
20868 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
20869 ELSEIF (MODEGA.EQ.4) THEN
20870 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
20871 C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
20872 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
20874 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
20881 *===RRM2===============================================================*
20884 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
20886 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20889 PARAMETER ( LINP = 5 ,
20893 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20894 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20896 & GEV2MB = 0.38938D0)
20898 * particle properties (BAMJET index convention)
20900 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20901 & IICH(210),IIBAR(210),K1(210),K2(210)
20902 * VDM parameter for photon-nucleus interactions
20903 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20905 S = Q2*(ONE-X)/X+AAM(1)**2
20908 IF (INTRGE(1).EQ.1) THEN
20909 AMLO2 = (3.0D0*AAM(13))**2
20910 ELSEIF (INTRGE(1).EQ.2) THEN
20915 IF (INTRGE(2).EQ.1) THEN
20917 ELSEIF (INTRGE(2).EQ.2) THEN
20922 AMHI20 = (ECM-AAM(1))**2
20923 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
20927 IF (AMHI2.LE.AM1C2) THEN
20928 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
20929 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
20930 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
20931 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
20933 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
20934 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
20935 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
20941 *===RM2================================================================*
20944 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
20946 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20949 PARAMETER ( LINP = 5 ,
20953 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20954 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20956 & GEV2MB = 0.38938D0)
20957 * VDM parameter for photon-nucleus interactions
20958 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20960 IF (RL2.LE.ZERO) THEN
20961 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
20962 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
20963 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
20965 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
20966 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
20967 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
20968 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
20970 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
20971 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
20977 *===SAM2===============================================================*
20980 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
20982 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20985 PARAMETER ( LINP = 5 ,
20989 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
20990 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
20991 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20993 & GEV2MB = 0.38938D0)
20995 * particle properties (BAMJET index convention)
20997 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20998 & IICH(210),IIBAR(210),K1(210),K2(210)
20999 * VDM parameter for photon-nucleus interactions
21000 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21003 IF (INTRGE(1).EQ.1) THEN
21004 AMLO2 = (3.0D0*AAM(13))**2
21005 ELSEIF (INTRGE(1).EQ.2) THEN
21010 IF (INTRGE(2).EQ.1) THEN
21012 ELSEIF (INTRGE(2).EQ.2) THEN
21017 AMHI20 = (ECM-AAM(1))**2
21018 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21022 YLO = LOG(AMLO2+Q2)
21023 YC1 = LOG(AM1C2+Q2)
21024 YC2 = LOG(AM2C2+Q2)
21025 YHI = LOG(AMHI2+Q2)
21026 IF (AMHI2.LE.AM1C2) THEN
21028 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
21035 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
21036 IF (YSAM2.LE.YC1) THEN
21038 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
21043 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
21044 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
21045 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
21047 DT_SAM2 = EXP(YSAM2)-Q2
21052 *===ckmt===============================================================*
21055 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
21058 ************************************************************************
21059 * This version dated 31.01.96 is written by S. Roesler *
21060 ************************************************************************
21062 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21065 PARAMETER ( LINP = 5 ,
21069 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
21071 PARAMETER (Q02 = 2.0D0,
21075 DIMENSION PD(-6:6),SEA(3),VAL(2)
21077 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
21078 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
21079 ADQ2 = LOG10(Q12)-LOG10(Q02)
21080 F2P = (F2Q1-F2Q0)/ADQ2
21081 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
21082 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
21083 F2PP = (F2PQ1-F2PQ0)/ADQ2
21084 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
21086 Q2 = MAX(SCALE**2.0D0,TINY10)
21087 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
21088 IF (Q2.LT.Q02) THEN
21089 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
21100 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
21113 C USEA = USEA*SMOOTH
21114 C DSEA = DSEA*SMOOTH
21123 CDECK ID>, DT_CKMTX
21124 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
21125 C**********************************************************************
21127 C PDF based on Regge theory, evolved with .... by ....
21129 C input: IPAR 2212 proton (not installed)
21133 C output: PD(-6:6) x*f(x) parton distribution functions
21134 C (PDFLIB convention: d = PD(1), u = PD(2) )
21136 C**********************************************************************
21139 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
21141 PARAMETER ( LINP = 5 ,
21150 C QCD lambda for evolution
21153 C Q0**2 for evolution
21157 C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
21158 C q(6)=x*charm, q(7)=x*gluon
21162 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
21164 IF(IPAR.EQ.2212) THEN
21165 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
21166 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
21167 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
21168 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
21169 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
21170 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
21171 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
21172 C ELSEIF (IPAR.EQ.45) THEN
21173 C CALL CKMTPO(1,0,XX,SB,QQ(1))
21174 C CALL CKMTPO(2,0,XX,SB,QQ(2))
21175 C CALL CKMTPO(3,0,XX,SB,QQ(3))
21176 C CALL CKMTPO(4,0,XX,SB,QQ(4))
21177 C CALL CKMTPO(5,0,XX,SB,QQ(5))
21178 C CALL CKMTPO(8,0,XX,SB,QQ(6))
21179 C CALL CKMTPO(7,0,XX,SB,QQ(7))
21180 ELSEIF (IPAR.EQ.100) THEN
21181 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
21182 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
21183 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
21184 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
21185 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
21186 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
21187 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
21189 WRITE(LOUT,'(1X,A,I4,A)')
21190 & 'CKMTX: IPAR =',IPAR,' not implemented!'
21196 PD(-4) = DBLE(QQ(6))
21197 PD(-3) = DBLE(QQ(3))
21198 PD(-2) = DBLE(QQ(4))
21199 PD(-1) = DBLE(QQ(5))
21200 PD(0) = DBLE(QQ(7))
21201 PD(1) = DBLE(QQ(2))
21202 PD(2) = DBLE(QQ(1))
21203 PD(3) = DBLE(QQ(3))
21204 PD(4) = DBLE(QQ(6))
21207 IF(IPAR.EQ.45) THEN
21208 CDN = (PD(1)-PD(-1))/2.D0
21209 CUP = (PD(2)-PD(-2))/2.D0
21210 PD(-1) = PD(-1) + CDN
21211 PD(-2) = PD(-2) + CUP
21215 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
21216 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
21217 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
21221 *===pdf0===============================================================*
21224 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
21226 ************************************************************************
21227 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
21228 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
21229 * IPAR = 2212 proton *
21231 * This version dated 31.01.96 is written by S. Roesler *
21232 ************************************************************************
21234 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21237 PARAMETER ( LINP = 5 ,
21241 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
21250 & DELTA0 = 0.07684D0,
21255 & ALPHAR = 0.415D0,
21259 PARAMETER (NPOINT=16)
21260 C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21261 DIMENSION SEA(3),VAL(2)
21263 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
21264 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
21266 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
21267 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
21268 SEA(1) = 0.75D0*SEA0
21271 VAL(1) = 9.0D0/4.0D0*VALU0
21272 VAL(2) = 9.0D0*VALD0
21273 GLU0 = SEA(1)/(1.0D0-X)
21274 F2 = SEA0+VALU0+VALD0
21275 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
21276 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
21277 & 1.0D0/9.0D0*(2.0D0*SEA(3))
21278 IF (ABS(F2-F2PDF).GT.TINY9) THEN
21279 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
21283 C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
21286 C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
21292 C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
21293 C VALU0 = 9.0D0/4.0D0*VALU0
21294 C VALD0 = 9.0D0*VALD0
21295 C SEA0 = 0.75D0*SEA0
21296 C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
21297 C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
21299 C GLU = GLU0*(1.0D0-SUMQ)/SUMG
21301 WRITE(LOUT,'(1X,A,I4,A)')
21302 & 'PDF0: IPAR =',IPAR,' not implemented!'
21309 *===ckmtq0=============================================================*
21311 CDECK ID>, DT_CKMTQ0
21312 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
21314 ************************************************************************
21315 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
21316 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
21317 * IPAR = 2212 proton *
21319 * This version dated 31.01.96 is written by S. Roesler *
21320 ************************************************************************
21322 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21325 PARAMETER ( LINP = 5 ,
21329 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
21338 & DELTA0 = 0.07684D0,
21343 & ALPHAR = 0.415D0,
21347 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
21348 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
21350 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
21351 IF (IPAR.EQ.2212) THEN
21358 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
21359 & (Q2/(Q2+A))**(1.0D0+DELTA)
21360 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
21361 & (Q2/(Q2+B))**(ALPHAR)
21362 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
21363 & (Q2/(Q2+B))**(ALPHAR)
21365 WRITE(LOUT,'(1X,A,I4,A)')
21366 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
21373 CDECK ID>, DT_CKMTDE
21374 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
21376 C**********************************************************************
21378 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
21380 C This version by S. Roesler, 30.01.96
21381 C**********************************************************************
21384 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
21385 EQUIVALENCE (GF(1,1,1),DL(1))
21388 DATA (DL(K),K= 1, 85) /
21389 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
21390 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
21391 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
21392 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
21393 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
21394 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
21395 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
21396 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
21397 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
21398 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
21399 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
21400 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
21401 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
21402 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
21403 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
21404 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
21405 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
21406 DATA (DL(K),K= 86, 170) /
21407 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
21408 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
21409 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
21410 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
21411 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
21412 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
21413 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21421 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21422 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
21423 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
21424 DATA (DL(K),K= 171, 255) /
21425 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
21426 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
21427 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
21428 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
21429 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
21430 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
21431 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
21432 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
21433 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
21434 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
21435 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
21436 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
21437 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
21438 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
21439 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
21440 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
21441 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
21442 DATA (DL(K),K= 256, 340) /
21443 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
21444 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
21445 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
21446 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
21447 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21455 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21456 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
21457 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
21458 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
21459 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
21460 DATA (DL(K),K= 341, 425) /
21461 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
21462 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
21463 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
21464 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
21465 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
21466 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
21467 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
21468 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
21469 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
21470 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
21471 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
21472 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
21473 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
21474 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
21475 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
21476 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
21477 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
21478 DATA (DL(K),K= 426, 510) /
21479 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
21480 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
21481 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21489 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21490 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
21491 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
21492 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
21493 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
21494 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
21495 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
21496 DATA (DL(K),K= 511, 595) /
21497 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
21498 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
21499 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
21500 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
21501 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
21502 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
21503 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
21504 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
21505 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
21506 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
21507 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
21508 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
21509 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
21510 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
21511 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
21512 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
21513 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
21514 DATA (DL(K),K= 596, 680) /
21515 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21523 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21524 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
21525 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
21526 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
21527 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
21528 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
21529 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
21530 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
21531 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
21532 DATA (DL(K),K= 681, 765) /
21533 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
21534 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
21535 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
21536 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
21537 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
21538 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
21539 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
21540 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
21541 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
21542 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
21543 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
21544 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
21545 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
21546 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
21547 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
21548 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
21549 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21550 DATA (DL(K),K= 766, 850) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21557 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21558 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
21559 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
21560 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
21561 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
21562 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
21563 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
21564 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
21565 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
21566 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
21567 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
21568 DATA (DL(K),K= 851, 935) /
21569 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
21570 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
21571 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
21572 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
21573 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
21574 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
21575 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
21576 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
21577 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
21578 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
21579 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
21580 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
21581 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
21582 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
21583 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21584 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21585 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21586 DATA (DL(K),K= 936, 1020) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21591 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21592 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
21593 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
21594 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
21595 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
21596 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
21597 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
21598 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
21599 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
21600 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
21601 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
21602 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
21603 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
21604 DATA (DL(K),K= 1021, 1105) /
21605 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
21606 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
21607 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
21608 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
21609 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
21610 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
21611 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
21612 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
21613 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
21614 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
21615 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
21616 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21621 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21622 DATA (DL(K),K= 1106, 1190) /
21623 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21624 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21625 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21626 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
21627 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
21628 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
21629 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
21630 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
21631 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
21632 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
21633 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
21634 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
21635 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
21636 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
21637 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
21638 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
21639 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
21640 DATA (DL(K),K= 1191, 1275) /
21641 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
21642 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
21643 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
21644 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
21645 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
21646 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
21647 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
21648 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
21649 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
21650 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21657 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21658 DATA (DL(K),K= 1276, 1360) /
21659 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21660 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
21661 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
21662 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
21663 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
21664 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
21665 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
21666 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
21667 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
21668 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
21669 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
21670 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
21671 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
21672 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
21673 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
21674 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
21675 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
21676 DATA (DL(K),K= 1361, 1445) /
21677 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
21678 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
21679 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
21680 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
21681 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
21682 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
21683 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
21684 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21692 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21693 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
21694 DATA (DL(K),K= 1446, 1530) /
21695 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
21696 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
21697 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
21698 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
21699 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
21700 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
21701 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
21702 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
21703 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
21704 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
21705 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
21706 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
21707 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
21708 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
21709 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
21710 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
21711 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
21712 DATA (DL(K),K= 1531, 1615) /
21713 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
21714 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
21715 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
21716 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
21717 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
21718 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21726 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21727 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
21728 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
21729 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
21730 DATA (DL(K),K= 1616, 1700) /
21731 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
21732 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
21733 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
21734 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
21735 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
21736 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
21737 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
21738 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
21739 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
21740 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
21741 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
21742 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
21743 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
21744 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
21745 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
21746 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
21747 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
21748 DATA (DL(K),K= 1701, 1785) /
21749 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
21750 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
21751 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
21752 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21760 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21761 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
21762 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
21763 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
21764 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
21765 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
21766 DATA (DL(K),K= 1786, 1870) /
21767 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
21768 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
21769 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
21770 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
21771 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
21772 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
21773 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
21774 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
21775 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
21776 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
21777 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
21778 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
21779 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
21780 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
21781 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
21782 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
21783 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
21784 DATA (DL(K),K= 1871, 1955) /
21785 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
21786 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21794 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21795 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
21796 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
21797 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
21798 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
21799 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
21800 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
21801 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
21802 DATA (DL(K),K= 1956, 2040) /
21803 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
21804 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
21805 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
21806 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
21807 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
21808 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
21809 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
21810 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
21811 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
21812 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
21813 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
21814 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
21815 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
21816 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
21817 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
21818 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
21819 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
21820 DATA (DL(K),K= 2041, 2125) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21828 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21829 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
21830 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
21831 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
21832 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
21833 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
21834 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
21835 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
21836 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
21837 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
21838 DATA (DL(K),K= 2126, 2210) /
21839 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
21840 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
21841 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
21842 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
21843 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
21844 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
21845 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
21846 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
21847 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
21848 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
21849 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
21850 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
21851 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
21852 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
21853 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
21854 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21855 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21856 DATA (DL(K),K= 2211, 2295) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21862 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21863 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
21864 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
21865 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
21866 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
21867 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
21868 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
21869 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
21870 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
21871 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
21872 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
21873 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
21874 DATA (DL(K),K= 2296, 2380) /
21875 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
21876 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
21877 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
21878 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
21879 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
21880 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
21881 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
21882 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
21883 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
21884 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
21885 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
21886 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
21887 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21891 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21892 DATA (DL(K),K= 2381, 2465) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21896 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21897 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
21898 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
21899 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
21900 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
21901 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
21902 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
21903 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
21904 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
21905 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
21906 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
21907 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
21908 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
21909 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
21910 DATA (DL(K),K= 2466, 2550) /
21911 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
21912 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
21913 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
21914 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
21915 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
21916 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
21917 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
21918 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
21919 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
21920 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
21921 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21927 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21928 DATA (DL(K),K= 2551, 2635) /
21929 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21930 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21931 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
21932 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
21933 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
21934 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
21935 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
21936 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
21937 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
21938 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
21939 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
21940 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
21941 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
21942 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
21943 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
21944 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
21945 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
21946 DATA (DL(K),K= 2636, 2720) /
21947 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
21948 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
21949 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
21950 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
21951 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
21952 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
21953 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
21954 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
21955 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21963 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
21964 DATA (DL(K),K= 2721, 2805) /
21965 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
21966 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
21967 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
21968 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
21969 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
21970 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
21971 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
21972 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
21973 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
21974 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
21975 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
21976 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
21977 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
21978 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
21979 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
21980 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
21981 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
21982 DATA (DL(K),K= 2806, 2890) /
21983 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
21984 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
21985 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
21986 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
21987 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
21988 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
21989 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21997 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
21998 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
21999 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
22000 DATA (DL(K),K= 2891, 2975) /
22001 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
22002 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
22003 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
22004 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
22005 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
22006 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
22007 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
22008 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
22009 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
22010 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
22011 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
22012 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
22013 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
22014 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
22015 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
22016 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
22017 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
22018 DATA (DL(K),K= 2976, 3060) /
22019 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
22020 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
22021 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
22022 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
22023 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22031 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22032 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
22033 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
22034 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
22035 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
22036 DATA (DL(K),K= 3061, 3145) /
22037 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
22038 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
22039 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
22040 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
22041 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
22042 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
22043 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
22044 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
22045 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
22046 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
22047 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
22048 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
22049 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
22050 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
22051 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
22052 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
22053 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
22054 DATA (DL(K),K= 3146, 3230) /
22055 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
22056 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
22057 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22065 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22066 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
22067 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
22068 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
22069 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
22070 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
22071 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
22072 DATA (DL(K),K= 3231, 3315) /
22073 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
22074 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
22075 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
22076 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
22077 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
22078 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
22079 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
22080 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
22081 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
22082 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
22083 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
22084 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
22085 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
22086 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
22087 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
22088 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
22089 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
22090 DATA (DL(K),K= 3316, 3400) /
22091 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22099 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22100 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
22101 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
22102 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
22103 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
22104 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
22105 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
22106 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
22107 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
22108 DATA (DL(K),K= 3401, 3485) /
22109 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
22110 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
22111 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
22112 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
22113 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
22114 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
22115 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
22116 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
22117 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
22118 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
22119 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
22120 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
22121 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
22122 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
22123 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
22124 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
22125 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22126 DATA (DL(K),K= 3486, 3570) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22133 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22134 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
22135 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
22136 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
22137 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
22138 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
22139 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
22140 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
22141 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
22142 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
22143 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
22144 DATA (DL(K),K= 3571, 3655) /
22145 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
22146 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
22147 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
22148 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
22149 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
22150 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
22151 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
22152 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
22153 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
22154 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
22155 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
22156 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
22157 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
22158 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
22159 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22160 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22161 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22162 DATA (DL(K),K= 3656, 3740) /
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.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22167 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22168 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
22169 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
22170 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
22171 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
22172 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
22173 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
22174 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
22175 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
22176 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
22177 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
22178 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
22179 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
22180 DATA (DL(K),K= 3741, 3825) /
22181 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
22182 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
22183 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
22184 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
22185 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
22186 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
22187 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
22188 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
22189 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
22190 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
22191 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
22192 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22197 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22198 DATA (DL(K),K= 3826, 3910) /
22199 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22200 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22201 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22202 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
22203 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
22204 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
22205 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
22206 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
22207 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
22208 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
22209 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
22210 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
22211 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
22212 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
22213 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
22214 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
22215 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
22216 DATA (DL(K),K= 3911, 3995) /
22217 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
22218 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
22219 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
22220 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
22221 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
22222 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
22223 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
22224 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
22225 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
22226 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
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 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22233 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22234 DATA (DL(K),K= 3996, 4000) /
22235 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22238 IF (X.GT.0.9985) RETURN
22239 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
22245 F1(L) = GF(I,IS,KL)
22246 F2(L) = GF(I,IS1,KL)
22248 A1 = DT_CKMTFF(X,F1)
22249 A2 = DT_CKMTFF(X,F2)
22254 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
22260 CDECK ID>, DT_CKMTPR
22261 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
22263 C**********************************************************************
22265 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22267 C This version by S. Roesler, 31.01.96
22268 C**********************************************************************
22271 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22272 EQUIVALENCE (GF(1,1,1),DL(1))
22275 DATA (DL(K),K= 1, 85) /
22276 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22277 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
22278 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
22279 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
22280 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
22281 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
22282 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
22283 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
22284 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
22285 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
22286 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
22287 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
22288 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
22289 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
22290 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
22291 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
22292 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
22293 DATA (DL(K),K= 86, 170) /
22294 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
22295 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
22296 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
22297 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
22298 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
22299 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
22300 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
22301 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
22302 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
22303 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
22304 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
22305 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
22306 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
22307 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
22308 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22309 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22310 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
22311 DATA (DL(K),K= 171, 255) /
22312 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
22313 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
22314 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
22315 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
22316 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
22317 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
22318 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
22319 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
22320 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
22321 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
22322 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
22323 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
22324 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
22325 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
22326 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
22327 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
22328 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
22329 DATA (DL(K),K= 256, 340) /
22330 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
22331 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
22332 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
22333 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
22334 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
22335 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
22336 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
22337 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
22338 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
22339 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
22340 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
22341 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
22342 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22343 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22344 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
22345 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
22346 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
22347 DATA (DL(K),K= 341, 425) /
22348 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
22349 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
22350 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
22351 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
22352 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
22353 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
22354 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
22355 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
22356 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
22357 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
22358 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
22359 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
22360 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
22361 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
22362 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
22363 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
22364 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
22365 DATA (DL(K),K= 426, 510) /
22366 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
22367 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
22368 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
22369 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
22370 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
22371 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
22372 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
22373 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
22374 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
22375 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22376 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22377 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22378 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
22379 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
22380 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
22381 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
22382 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
22383 DATA (DL(K),K= 511, 595) /
22384 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
22385 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
22386 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
22387 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
22388 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
22389 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
22390 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
22391 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
22392 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
22393 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
22394 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
22395 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
22396 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
22397 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
22398 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
22399 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
22400 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
22401 DATA (DL(K),K= 596, 680) /
22402 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
22403 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
22404 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
22405 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
22406 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
22407 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
22408 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
22409 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22410 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22411 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22412 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
22413 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
22414 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
22415 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
22416 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
22417 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
22418 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
22419 DATA (DL(K),K= 681, 765) /
22420 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
22421 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
22422 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
22423 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
22424 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
22425 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
22426 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
22427 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
22428 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
22429 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
22430 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
22431 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
22432 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
22433 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
22434 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
22435 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
22436 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
22437 DATA (DL(K),K= 766, 850) /
22438 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
22439 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
22440 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
22441 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
22442 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
22443 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22444 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22445 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22446 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
22447 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
22448 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
22449 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
22450 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
22451 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
22452 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
22453 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
22454 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
22455 DATA (DL(K),K= 851, 935) /
22456 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
22457 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
22458 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
22459 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
22460 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
22461 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
22462 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
22463 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
22464 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
22465 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
22466 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
22467 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
22468 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
22469 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
22470 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
22471 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
22472 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
22473 DATA (DL(K),K= 936, 1020) /
22474 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
22475 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
22476 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
22477 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22478 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22479 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22480 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
22481 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
22482 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
22483 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
22484 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
22485 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
22486 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
22487 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
22488 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
22489 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
22490 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
22491 DATA (DL(K),K= 1021, 1105) /
22492 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
22493 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
22494 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
22495 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
22496 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
22497 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
22498 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
22499 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
22500 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
22501 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
22502 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
22503 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
22504 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
22505 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
22506 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
22507 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
22508 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
22509 DATA (DL(K),K= 1106, 1190) /
22510 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
22511 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
22512 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22513 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22514 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
22515 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
22516 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
22517 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
22518 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
22519 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
22520 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
22521 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
22522 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
22523 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
22524 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
22525 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
22526 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
22527 DATA (DL(K),K= 1191, 1275) /
22528 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
22529 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
22530 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
22531 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
22532 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
22533 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
22534 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
22535 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
22536 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
22537 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
22538 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
22539 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
22540 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
22541 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
22542 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
22543 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
22544 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
22545 DATA (DL(K),K= 1276, 1360) /
22546 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22547 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22548 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
22549 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
22550 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
22551 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
22552 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
22553 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
22554 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
22555 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
22556 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
22557 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
22558 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
22559 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
22560 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
22561 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
22562 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
22563 DATA (DL(K),K= 1361, 1445) /
22564 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
22565 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
22566 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
22567 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
22568 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
22569 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
22570 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
22571 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
22572 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
22573 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
22574 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
22575 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
22576 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
22577 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
22578 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
22579 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22580 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22581 DATA (DL(K),K= 1446, 1530) /
22582 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
22583 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
22584 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
22585 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
22586 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
22587 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
22588 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
22589 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
22590 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
22591 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
22592 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
22593 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
22594 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
22595 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
22596 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
22597 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
22598 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
22599 DATA (DL(K),K= 1531, 1615) /
22600 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
22601 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
22602 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
22603 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
22604 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
22605 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
22606 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
22607 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
22608 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
22609 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
22610 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
22611 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
22612 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
22613 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22614 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22615 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
22616 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
22617 DATA (DL(K),K= 1616, 1700) /
22618 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
22619 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
22620 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
22621 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
22622 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
22623 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
22624 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
22625 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
22626 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
22627 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
22628 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
22629 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
22630 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
22631 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
22632 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
22633 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
22634 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
22635 DATA (DL(K),K= 1701, 1785) /
22636 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
22637 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
22638 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
22639 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
22640 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
22641 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
22642 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
22643 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
22644 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
22645 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
22646 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
22647 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22648 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22649 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
22650 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
22651 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
22652 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
22653 DATA (DL(K),K= 1786, 1870) /
22654 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
22655 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
22656 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
22657 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
22658 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
22659 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
22660 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
22661 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
22662 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
22663 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
22664 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
22665 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
22666 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
22667 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
22668 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
22669 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
22670 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
22671 DATA (DL(K),K= 1871, 1955) /
22672 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
22673 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
22674 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
22675 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
22676 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
22677 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
22678 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
22679 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
22680 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
22681 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22682 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22683 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
22684 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
22685 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
22686 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
22687 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
22688 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
22689 DATA (DL(K),K= 1956, 2040) /
22690 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
22691 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
22692 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
22693 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
22694 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
22695 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
22696 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
22697 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
22698 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
22699 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
22700 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
22701 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
22702 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
22703 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
22704 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
22705 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
22706 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
22707 DATA (DL(K),K= 2041, 2125) /
22708 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
22709 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
22710 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
22711 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
22712 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
22713 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
22714 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
22715 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22716 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22717 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
22718 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
22719 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
22720 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
22721 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
22722 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
22723 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
22724 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
22725 DATA (DL(K),K= 2126, 2210) /
22726 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
22727 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
22728 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
22729 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
22730 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
22731 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
22732 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
22733 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
22734 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
22735 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
22736 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
22737 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
22738 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
22739 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
22740 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
22741 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
22742 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
22743 DATA (DL(K),K= 2211, 2295) /
22744 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
22745 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
22746 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
22747 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
22748 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
22749 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22750 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
22751 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
22752 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
22753 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
22754 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
22755 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
22756 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
22757 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
22758 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
22759 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
22760 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
22761 DATA (DL(K),K= 2296, 2380) /
22762 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
22763 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
22764 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
22765 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
22766 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
22767 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
22768 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
22769 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
22770 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
22771 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
22772 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
22773 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
22774 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
22775 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
22776 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
22777 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
22778 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
22779 DATA (DL(K),K= 2381, 2465) /
22780 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
22781 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
22782 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
22783 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22784 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
22785 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
22786 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
22787 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
22788 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
22789 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
22790 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
22791 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
22792 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
22793 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
22794 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
22795 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
22796 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
22797 DATA (DL(K),K= 2466, 2550) /
22798 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
22799 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
22800 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
22801 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
22802 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
22803 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
22804 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
22805 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
22806 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
22807 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
22808 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
22809 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
22810 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
22811 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
22812 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
22813 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
22814 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
22815 DATA (DL(K),K= 2551, 2635) /
22816 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
22817 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22818 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
22819 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
22820 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
22821 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
22822 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
22823 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
22824 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
22825 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
22826 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
22827 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
22828 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
22829 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
22830 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
22831 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
22832 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
22833 DATA (DL(K),K= 2636, 2720) /
22834 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
22835 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
22836 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
22837 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
22838 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
22839 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
22840 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
22841 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
22842 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
22843 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
22844 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
22845 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
22846 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
22847 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
22848 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
22849 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
22850 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22851 DATA (DL(K),K= 2721, 2805) /
22852 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
22853 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
22854 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
22855 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
22856 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
22857 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
22858 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
22859 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
22860 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
22861 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
22862 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
22863 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
22864 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
22865 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
22866 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
22867 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
22868 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
22869 DATA (DL(K),K= 2806, 2890) /
22870 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
22871 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
22872 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
22873 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
22874 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
22875 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
22876 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
22877 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
22878 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
22879 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
22880 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
22881 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
22882 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
22883 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
22884 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22885 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
22886 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
22887 DATA (DL(K),K= 2891, 2975) /
22888 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
22889 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
22890 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
22891 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
22892 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
22893 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
22894 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
22895 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
22896 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
22897 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
22898 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
22899 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
22900 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
22901 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
22902 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
22903 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
22904 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
22905 DATA (DL(K),K= 2976, 3060) /
22906 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
22907 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
22908 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
22909 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
22910 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
22911 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
22912 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
22913 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
22914 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
22915 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
22916 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
22917 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
22918 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22919 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
22920 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
22921 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
22922 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
22923 DATA (DL(K),K= 3061, 3145) /
22924 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
22925 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
22926 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
22927 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
22928 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
22929 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
22930 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
22931 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
22932 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
22933 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
22934 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
22935 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
22936 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
22937 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
22938 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
22939 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
22940 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
22941 DATA (DL(K),K= 3146, 3230) /
22942 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
22943 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
22944 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
22945 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
22946 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
22947 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
22948 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
22949 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
22950 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
22951 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
22952 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22953 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
22954 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
22955 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
22956 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
22957 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
22958 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
22959 DATA (DL(K),K= 3231, 3315) /
22960 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
22961 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
22962 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
22963 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
22964 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
22965 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
22966 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
22967 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
22968 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
22969 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
22970 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
22971 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
22972 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
22973 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
22974 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
22975 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
22976 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
22977 DATA (DL(K),K= 3316, 3400) /
22978 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
22979 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
22980 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
22981 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
22982 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
22983 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
22984 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
22985 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
22986 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22987 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
22988 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
22989 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
22990 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
22991 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
22992 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
22993 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
22994 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
22995 DATA (DL(K),K= 3401, 3485) /
22996 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
22997 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
22998 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
22999 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
23000 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
23001 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
23002 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
23003 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
23004 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
23005 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
23006 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
23007 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
23008 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
23009 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
23010 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
23011 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
23012 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
23013 DATA (DL(K),K= 3486, 3570) /
23014 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
23015 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
23016 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
23017 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
23018 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
23019 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
23020 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23021 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
23022 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
23023 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
23024 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
23025 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
23026 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
23027 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
23028 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
23029 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
23030 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
23031 DATA (DL(K),K= 3571, 3655) /
23032 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
23033 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
23034 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
23035 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
23036 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
23037 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
23038 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
23039 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
23040 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
23041 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
23042 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
23043 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
23044 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
23045 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
23046 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
23047 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
23048 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
23049 DATA (DL(K),K= 3656, 3740) /
23050 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
23051 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
23052 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
23053 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
23054 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23055 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23056 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
23057 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
23058 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
23059 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
23060 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
23061 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
23062 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
23063 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
23064 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
23065 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
23066 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
23067 DATA (DL(K),K= 3741, 3825) /
23068 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
23069 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
23070 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
23071 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
23072 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
23073 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
23074 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
23075 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
23076 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
23077 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
23078 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
23079 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
23080 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
23081 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
23082 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
23083 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
23084 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
23085 DATA (DL(K),K= 3826, 3910) /
23086 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
23087 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
23088 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23089 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23090 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
23091 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
23092 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
23093 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
23094 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
23095 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
23096 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
23097 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
23098 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
23099 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
23100 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
23101 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
23102 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
23103 DATA (DL(K),K= 3911, 3995) /
23104 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
23105 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
23106 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
23107 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
23108 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
23109 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
23110 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
23111 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
23112 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
23113 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
23114 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
23115 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
23116 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
23117 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
23118 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
23119 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
23120 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
23121 DATA (DL(K),K= 3996, 4000) /
23122 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23125 IF (X.GT.0.9985) RETURN
23126 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23132 F1(L) = GF(I,IS,KL)
23133 F2(L) = GF(I,IS1,KL)
23135 A1 = DT_CKMTFF(X,F1)
23136 A2 = DT_CKMTFF(X,F2)
23141 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23146 CDECK ID>, DT_CKMTFF
23147 FUNCTION DT_CKMTFF(X,FVL)
23148 C**********************************************************************
23150 C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
23151 C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
23152 C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
23155 C**********************************************************************
23158 DIMENSION FVL(25),XGRID(25)
23159 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
23160 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
23164 IF(X.LT.XGRID(I)) GO TO 2
23169 ELSE IF(I.GT.23) THEN
23175 BXI=LOG(1.-XGRID(I))
23177 BXJ=LOG(1.-XGRID(J))
23179 BXK=LOG(1.-XGRID(K))
23180 FI=LOG(ABS(FVL(I)) +1.E-15)
23181 FJ=LOG(ABS(FVL(J)) +1.E-16)
23182 FK=LOG(ABS(FVL(K)) +1.E-17)
23183 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
23184 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
23186 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
23187 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
23188 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
23190 C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
23191 C WRITE(6,2001) X,FVL
23192 C 2001 FORMAT(8E12.4)
23193 C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
23195 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
23199 *===fluini=============================================================*
23201 CDECK ID>, DT_FLUINI
23202 SUBROUTINE DT_FLUINI
23204 ************************************************************************
23205 * Initialisation of the nucleon-nucleon cross section fluctuation *
23206 * treatment. The original version by J. Ranft. *
23207 * This version dated 21.04.95 is revised by S. Roesler. *
23208 ************************************************************************
23210 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23213 PARAMETER ( LINP = 5 ,
23217 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
23219 PARAMETER ( A = 0.1D0,
23225 * n-n cross section fluctuations
23226 PARAMETER (NBINS = 1000)
23227 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
23228 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
23231 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
23240 FLUS = ((X-B)/(OM*B))**N
23241 IF (FLUS.LE.20.0D0) THEN
23242 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
23246 FLUSU = FLUSU+FLUSI(I)
23249 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
23254 C1001 FORMAT(1X,'FLUCTUATIONS')
23255 C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
23258 AF = DBLE(I)*0.001D0
23260 IF (AF.LE.FLUSI(J)) THEN
23261 FLUIXX(I) = FLUIX(J)
23267 FLUIXX(1) = FLUIX(1)
23268 FLUIXX(NBINS) = FLUIX(NBINS)
23273 *===sigtab=============================================================*
23275 CDECK ID>, DT_SIGTBL
23276 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
23278 ************************************************************************
23279 * This version dated 18.11.95 is written by S. Roesler *
23280 ************************************************************************
23282 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23285 PARAMETER ( LINP = 5 ,
23289 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
23290 & OHALF=0.5D0,ONE=1.0D0)
23291 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
23295 * particle properties (BAMJET index convention)
23297 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
23298 & IICH(210),IIBAR(210),K1(210),K2(210)
23300 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
23301 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
23302 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
23304 DATA LINIT /.FALSE./
23306 * precalculation and tabulation of elastic cross sections
23307 IF (ABS(MODE).EQ.1) THEN
23309 & OPEN(LDAT,FILE='sigtab.out',STATUS='UNKNOWN')
23310 PLABLX = LOG10(PLO)
23311 PLABHX = LOG10(PHI)
23312 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
23314 PLAB = PLABLX+DBLE(I-1)*DPLAB
23319 C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
23320 C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
23322 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
23323 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
23326 IF (MODE.EQ.1) THEN
23327 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
23328 & (SIGEN(IDX,I),IDX=1,5)
23329 1000 FORMAT(F5.1,10F7.2)
23332 IF (MODE.EQ.1) CLOSE(LDAT)
23336 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
23337 & .AND.(PTOT.LE.PHI) ) THEN
23339 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
23340 PLABX = LOG10(PTOT)
23341 IF (PLABX.LE.PLABLX) THEN
23344 ELSEIF (PLABX.GE.PLABHX) THEN
23348 I1 = INT((PLABX-PLABLX)/DPLAB)+1
23351 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
23352 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
23353 PBIN = PLAB2X-PLAB1X
23354 IF (PBIN.GT.TINY10) THEN
23355 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
23360 SIG1 = SIGEP(IDX,I1)
23361 SIG2 = SIGEP(IDX,I2)
23363 SIG1 = SIGEN(IDX,I1)
23364 SIG2 = SIGEN(IDX,I2)
23366 SIGE = SIG1+RATX*(SIG2-SIG1)
23374 *===xstabl=============================================================*
23376 CDECK ID>, DT_XSTABL
23377 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
23379 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23382 PARAMETER ( LINP = 5 ,
23386 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
23387 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
23388 LOGICAL LLAB,LELOG,LQLOG
23390 * particle properties (BAMJET index convention)
23392 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
23393 & IICH(210),IIBAR(210),K1(210),K2(210)
23394 * properties of interacting particles
23395 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
23397 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
23399 * Glauber formalism: cross sections
23400 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
23401 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
23402 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
23403 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
23404 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
23405 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
23406 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
23407 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
23408 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
23409 & BSLOPE,NEBINI,NQBINI
23410 * emulsion treatment
23411 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
23416 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
23419 IF (ELO.GT.EHI) ELO = EHI
23420 LELOG = WHAT(3).LT.ZERO
23421 NEBINS = MAX(INT(ABS(WHAT(3))),1)
23422 DEBINS = (EHI-ELO)/DBLE(NEBINS)
23426 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
23430 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
23431 LQLOG = WHAT(6).LT.ZERO
23432 NQBINS = MAX(INT(ABS(WHAT(6))),1)
23433 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
23435 AQ2LO = LOG10(Q2LO)
23436 AQ2HI = LOG10(Q2HI)
23437 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
23440 IF ( ELO.EQ. EHI) NEBINS = 0
23441 IF (Q2LO.EQ.Q2HI) NQBINS = 0
23443 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
23444 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
23445 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
23446 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
23447 & ' A_p = ',I3,' A_t = ',I3,/)
23449 C IF (IJPROJ.NE.7) THEN
23450 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
23451 * normalize fractions of emulsion components
23452 IF (NCOMPO.GT.0) THEN
23455 SUMFRA = SUMFRA+EMUFRA(I)
23457 IF (SUMFRA.GT.ZERO) THEN
23459 EMUFRA(I) = EMUFRA(I)/SUMFRA
23464 C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
23468 E = 10**(AELO+DBLE(I-1)*ADEBIN)
23470 E = ELO+DBLE(I-1)*DEBINS
23474 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
23476 Q2 = Q2LO+DBLE(J-1)*DQBINS
23478 c IF (IJPROJ.NE.7) THEN
23482 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
23488 IF (IJPROJ.EQ.7) Q2I = Q2
23489 IF (NCOMPO.GT.0) THEN
23492 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
23495 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
23496 C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
23498 IF (NCOMPO.GT.0) THEN
23517 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
23518 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
23519 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
23520 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
23521 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
23522 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
23523 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
23524 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
23525 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
23526 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
23527 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
23528 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
23529 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
23530 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
23531 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
23532 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
23533 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
23534 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
23536 XPRO1= XPRO1+EMUFRA(IC)*YPRO
23546 WRITE(LOUT,'(8E9.3)')
23547 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
23548 C WRITE(LOUT,'(4E9.3)')
23549 C & E,XDEL,XDQE,XDEL+XDQE
23551 WRITE(LOUT,'(11E10.3)')
23553 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
23554 & XSQE2(1,1,1),XSPRO(1,1,1),
23555 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
23556 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
23557 & XSDEL(1,1,1)+XSDQE(1,1,1)
23558 C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
23559 C & XSDEL(1,1,1)+XSDQE(1,1,1)
23563 c IF (IT.GT.1) THEN
23564 c IF (IXSQEL.EQ.0) THEN
23565 cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
23566 cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
23567 c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
23568 c & STOT,ETOT,SIN,EIN,STOT0)
23569 c IF (IRATIO.EQ.1) THEN
23570 c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
23571 cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
23572 cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
23573 c*!! save cross sections
23578 c STOT = STOT/(DBLE(IT)*STGP)
23579 c SIN = SIN/(DBLE(IT)*SIGP)
23586 c & ' XSTABL: qel. xs. not implemented for nuclei'
23593 c IF (IXSQEL.EQ.0) THEN
23594 c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
23597 c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
23601 c IF (IT.GT.1) THEN
23602 c IF (IXSQEL.EQ.0) THEN
23603 c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
23604 c & STOT,ETOT,SIN,EIN,STOT0)
23605 c IF (IRATIO.EQ.1) THEN
23606 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
23607 c*!! save cross sections
23612 c STOT = STOT/(DBLE(IT)*STGP)
23613 c SIN = SIN/(DBLE(IT)*SIGP)
23620 c & ' XSTABL: qel. xs. not implemented for nuclei'
23627 c IF (IXSQEL.EQ.0) THEN
23628 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
23631 c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
23635 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
23636 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
23637 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
23638 c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
23646 *===testxs=============================================================*
23648 CDECK ID>, DT_TESTXS
23649 SUBROUTINE DT_TESTXS
23651 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23654 DIMENSION XSTOT(26,2),XSELA(26,2)
23656 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
23657 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
23658 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
23659 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
23664 APLABL = LOG10(PLABL)
23665 APLABH = LOG10(PLABH)
23666 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
23668 ADP = APLABL+DBLE(I-1)*ADPLAB
23671 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
23672 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
23674 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
23675 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
23676 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
23677 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
23679 1000 FORMAT(F8.3,26F9.3)
23683 ************************************************************************
23685 * DTUNUC 2.0: library routines *
23686 * processed by S. Roesler, 6.5.95 *
23688 ************************************************************************
23690 * 1) Handling of parton momenta
23691 * SUBROUTINE MASHEL
23692 * SUBROUTINE DFERMI
23694 * 2) Handling of parton flavors and particle indices
23695 * INTEGER FUNCTION IPDG2B
23696 * INTEGER FUNCTION IB2PDG
23697 * INTEGER FUNCTION IQUARK
23698 * INTEGER FUNCTION IBJQUA
23699 * INTEGER FUNCTION ICIHAD
23700 * INTEGER FUNCTION IPDGHA
23701 * INTEGER FUNCTION MCHAD
23702 * SUBROUTINE FLAHAD
23704 * 3) Energy-momentum and quantum number conservation check routines
23707 * SUBROUTINE EVTEMC
23708 * SUBROUTINE EVTFLC
23709 * SUBROUTINE EVTCHG
23711 * 4) Transformations
23713 * SUBROUTINE LTRANS
23715 * SUBROUTINE DALTRA
23716 * SUBROUTINE DTRAFO
23717 * SUBROUTINE STTRAN
23718 * SUBROUTINE MYTRAN
23719 * SUBROUTINE LT2LAO
23720 * SUBROUTINE LT2LAB
23722 * 5) Sampling from distributions
23723 * INTEGER FUNCTION NPOISS
23724 * DOUBLE PRECISION FUNCTION SAMPXB
23725 * DOUBLE PRECISION FUNCTION SAMPEX
23726 * DOUBLE PRECISION FUNCTION SAMSQX
23727 * DOUBLE PRECISION FUNCTION BETREJ
23728 * DOUBLE PRECISION FUNCTION DGAMRN
23729 * DOUBLE PRECISION FUNCTION DBETAR
23730 * SUBROUTINE RANNOR
23732 * SUBROUTINE DSFECF
23735 * 6) Special functions, algorithms and service routines
23736 * DOUBLE PRECISION FUNCTION YLAMB
23739 * SUBROUTINE DT_XTIME
23741 * 7) Random number generator package
23742 * DOUBLE PRECISION FUNCTION DT_RNDM
23743 * SUBROUTINE DT_RNDMST
23744 * SUBROUTINE DT_RNDMIN
23745 * SUBROUTINE DT_RNDMOU
23746 * SUBROUTINE DT_RNDMTE
23748 ************************************************************************
23750 * 1) Handling of parton momenta *
23752 ************************************************************************
23754 *===mashel=============================================================*
23756 CDECK ID>, DT_MASHEL
23757 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
23759 ************************************************************************
23761 * rescaling of momenta of two partons to put both *
23764 * input: PA1,PA2 input momentum vectors *
23765 * XM1,2 desired masses of particles afterwards *
23766 * P1,P2 changed momentum vectors *
23768 * The original version is written by R. Engel. *
23769 * This version dated 12.12.94 is modified by S. Roesler. *
23770 ************************************************************************
23772 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23775 PARAMETER ( LINP = 5 ,
23779 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
23781 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
23785 * Lorentz transformation into system CMS
23790 XPTOT = SQRT(PX**2+PY**2+PZ**2)
23791 XMS = (EE-XPTOT)*(EE+XPTOT)
23792 IF(XMS.LT.(XM1+XM2)**2) THEN
23793 C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
23801 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
23802 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
23805 C SID = SQRT((ONE-COD)*(ONE+COD))
23806 PPT = SQRT(P1(1)**2+P1(2)**2)
23810 IF(PTOT1*SID.GT.TINY10) THEN
23811 COF = P1(1)/(SID*PTOT1)
23812 SIF = P1(2)/(SID*PTOT1)
23813 ANORF = SQRT(COF*COF+SIF*SIF)
23817 * new CM momentum and energies (for masses XM1,XM2)
23818 XM12 = SIGN(XM1**2,XM1)
23819 XM22 = SIGN(XM2**2,XM2)
23821 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
23822 EE1 = SQRT(XM12+PCMP**2)
23826 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
23827 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
23828 & PTOT1,P1(1),P1(2),P1(3),P1(4))
23829 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
23830 & PTOT2,P2(1),P2(2),P2(3),P2(4))
23831 * check consistency
23833 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
23835 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
23837 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
23839 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
23844 IF (IDEV.NE.0) THEN
23845 WRITE(LOUT,'(/1X,A,I3)')
23846 & 'MASHEL: inconsistent transformation',IDEV
23847 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
23848 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
23849 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
23850 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
23851 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
23852 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
23861 *===dfermi=============================================================*
23863 CDECK ID>, DT_DFERMI
23864 SUBROUTINE DT_DFERMI(GPART)
23866 ************************************************************************
23867 * Find largest of three random numbers. *
23868 ************************************************************************
23870 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23876 G(I)=DT_RNDM(GPART)
23878 IF (G(3).LT.G(2)) GOTO 40
23879 IF (G(3).LT.G(1)) GOTO 30
23884 40 IF (G(2).LT.G(1)) GOTO 30
23890 ************************************************************************
23892 * 2) Handling of parton flavors and particle indices *
23894 ************************************************************************
23896 *===ipdg2b=============================================================*
23898 CDECK ID>, IDT_IPDG2B
23899 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
23901 ************************************************************************
23903 * conversion of quark numbering scheme *
23905 * input: PDG parton numbering *
23906 * for diquarks: NN number of the constituent quark *
23907 * (e.g. ID=2301,NN=1 -> ICONV2=1) *
23909 * output: BAMJET particle codes *
23910 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
23911 * 2 d 8 a-d -2 a-d *
23912 * 3 s 9 a-s -3 a-s *
23913 * 4 c 10 a-c -4 a-c *
23915 * This is a modified version of ICONV2 written by R. Engel. *
23916 * This version dated 13.12.94 is written by S. Roesler. *
23917 ************************************************************************
23919 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23922 PARAMETER ( LINP = 5 ,
23930 IF (IDA.GE.1000) KF = 4
23931 IDA = IDA/(10**(KF-NN))
23934 * exchange up and dn quarks
23937 ELSEIF (IDA.EQ.2) THEN
23942 IF (MODE.EQ.1) THEN
23953 *===ib2pdg=============================================================*
23955 CDECK ID>, IDT_IB2PDG
23956 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
23958 ************************************************************************
23960 * conversion of quark numbering scheme *
23962 * input: BAMJET particle codes *
23963 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
23964 * 2 d 8 a-d -2 a-d *
23965 * 3 s 9 a-s -3 a-s *
23966 * 4 c 10 a-c -4 a-c *
23968 * output: PDG parton numbering *
23970 * This version dated 13.12.94 is written by S. Roesler. *
23971 ************************************************************************
23973 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23976 PARAMETER ( LINP = 5 ,
23980 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
23981 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
23982 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
23983 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
23984 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
23988 IF (MODE.EQ.1) THEN
23989 IF (ID1.GT.6) IDA = -(ID1-6)
23990 IF (ID2.GT.6) IDB = -(ID2-6)
23993 IDT_IB2PDG = IHKKQ(IDA)
23995 IDT_IB2PDG = IHKKQQ(IDA,IDB)
24001 *===ipdgqu=============================================================*
24003 CDECK ID>, IDT_IQUARK
24004 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
24006 ************************************************************************
24008 * quark contents according to PDG conventions *
24009 * (random selection in case of quark mixing) *
24011 * input: IDBAMJ BAMJET particle code *
24012 * K 1..3 quark number *
24014 * output: 1 d (anti --> neg.) *
24019 * This version written by R. Engel. *
24020 ************************************************************************
24022 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24025 IQ = IDT_IBJQUA(K,IDBAMJ)
24030 * exchange of up and down
24031 IF (ABS(IQ).EQ.1) THEN
24033 ELSEIF (ABS(IQ).EQ.2) THEN
24041 *===ibamq==============================================================*
24043 CDECK ID>, IDT_IBJQUA
24044 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
24046 ************************************************************************
24048 * quark contents according to BAMJET conventions *
24049 * (random selection in case of quark mixing) *
24051 * input: IDBAMJ BAMJET particle code *
24052 * K 1..3 quark number *
24054 * output: 1 u 7 u bar *
24059 * This version written by R. Engel. *
24060 ************************************************************************
24062 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24065 DIMENSION ITAB(3,210)
24066 DATA ((ITAB(I,K),I=1,3),K=1,30) /
24067 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
24068 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24069 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
24071 C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24072 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
24074 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
24076 C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
24077 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
24079 C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
24080 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
24082 & 1, 2, 3, 201,202, 0, 2, 9, 0,
24083 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
24084 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
24085 DATA ((ITAB(I,K),I=1,3),K=31,60) /
24086 & 3, 9, 0, 1, 8, 0, 203,204, 0,
24087 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
24088 & 2, 9, 0, 3, 7, 0, 3, 8, 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, 0, 0, 0, 0, 0, 0,
24092 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24093 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
24094 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
24095 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
24096 DATA ((ITAB(I,K),I=1,3),K=61,90) /
24097 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24098 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24099 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
24100 & 8, 8, 8, 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 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24106 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
24107 DATA ((ITAB(I,K),I=1,3),K=91,120) /
24108 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24109 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
24110 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
24111 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
24112 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
24113 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
24114 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
24115 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
24116 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
24117 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
24118 DATA ((ITAB(I,K),I=1,3),K=121,150) /
24119 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
24120 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
24121 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
24122 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24123 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24124 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
24125 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
24126 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
24127 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
24128 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
24129 DATA ((ITAB(I,K),I=1,3),K=151,180) /
24130 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
24131 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
24132 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
24133 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
24134 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
24135 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
24136 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
24137 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
24138 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
24139 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
24140 DATA ((ITAB(I,K),I=1,3),K=181,210) /
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, 0, 0, 0,
24146 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24147 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
24148 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
24149 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24150 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
24154 IF (ITAB(1,IDBAMJ).LE.200) THEN
24155 ID = ITAB(K,IDBAMJ)
24157 IF(IDOLD.NE.IDBAMJ) THEN
24158 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
24159 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
24171 *===icihad=============================================================*
24173 CDECK ID>, IDT_ICIHAD
24174 INTEGER FUNCTION IDT_ICIHAD(MCIND)
24176 ************************************************************************
24177 * Conversion of particle index PDG proposal --> BAMJET-index scheme *
24178 * This is a completely new version dated 25.10.95. *
24179 * Renamed to be not in conflict with the modified PHOJET-version *
24180 ************************************************************************
24182 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24185 * hadron index conversion (BAMJET <--> PDG)
24186 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
24187 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
24192 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
24193 IF (MCIND.LT.0) THEN
24198 IF (KPDG.GE.10000) THEN
24200 IDT_ICIHAD = IBAM5(JSIGN,I)
24201 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
24204 ELSEIF (KPDG.GE.1000) THEN
24206 IDT_ICIHAD = IBAM4(JSIGN,I)
24207 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
24210 ELSEIF (KPDG.GE.100) THEN
24212 IDT_ICIHAD = IBAM3(JSIGN,I)
24213 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
24216 ELSEIF (KPDG.GE.10) THEN
24218 IDT_ICIHAD = IBAM2(JSIGN,I)
24219 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
24228 *===ipdgha=============================================================*
24230 CDECK ID>, IDT_IPDGHA
24231 INTEGER FUNCTION IDT_IPDGHA(MCIND)
24233 ************************************************************************
24234 * Conversion of particle index BAMJET-index scheme --> PDG proposal *
24235 * Adopted from the original by S. Roesler. This version dated 12.5.95 *
24236 * Renamed to be not in conflict with the modified PHOJET-version *
24237 ************************************************************************
24239 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24242 * hadron index conversion (BAMJET <--> PDG)
24243 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
24244 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
24247 IDT_IPDGHA = IAMCIN(MCIND)
24252 *===flahad=============================================================*
24254 CDECK ID>, DT_FLAHAD
24255 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
24257 ************************************************************************
24258 * sampling of FLAvor composition for HADrons/photons *
24259 * ID BAMJET-id of hadron *
24260 * IF1,2,3 flavor content *
24261 * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
24262 * Note: - u,d numbering as in BAMJET *
24263 * - ID .le. 30 !! *
24264 * This version dated 12.03.96 is written by S. Roesler *
24265 ************************************************************************
24267 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24270 * auxiliary common for reggeon exchange (DTUNUC 1.x)
24271 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
24272 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
24273 & IQTCHR(-6:6),MQUARK(3,39)
24275 DIMENSION JSEL(3,6)
24276 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
24280 * photon (charge dependent flavour sampling)
24281 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
24285 ELSE IF(K.EQ.5) THEN
24292 IF(DT_RNDM(ONE).LT.0.5D0) THEN
24300 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
24301 IF1 = MQUARK(JSEL(1,IX),ID)
24302 IF2 = MQUARK(JSEL(2,IX),ID)
24303 IF3 = MQUARK(JSEL(3,IX),ID)
24304 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
24307 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
24316 *===mchad==============================================================*
24318 CDECK ID>, IDT_MCHAD
24319 INTEGER FUNCTION IDT_MCHAD(ITDTU)
24321 ************************************************************************
24322 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
24323 * Adopted from the original by S. Roesler. This version dated 6.5.95 *
24324 ************************************************************************
24326 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24329 DIMENSION ITRANS(210)
24330 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
24331 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
24332 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
24333 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
24334 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
24335 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
24336 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
24338 IDT_MCHAD = ITRANS(ITDTU)
24343 ************************************************************************
24345 * 3) Energy-momentum and quantum number conservation check routines *
24347 ************************************************************************
24349 *===emc1===============================================================*
24352 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
24354 ************************************************************************
24355 * This version dated 15.12.94 is written by S. Roesler *
24356 ************************************************************************
24358 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24361 PARAMETER ( LINP = 5 ,
24365 PARAMETER (TINY10=1.0D-10)
24367 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
24371 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
24372 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
24374 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
24375 IF (MODE.EQ.1) THEN
24376 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
24377 ELSEIF (MODE.EQ.2) THEN
24378 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
24380 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
24381 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
24382 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
24383 ELSEIF (MODE.LT.0) THEN
24384 IF (MODE.EQ.-1) THEN
24385 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
24386 ELSEIF (MODE.EQ.-2) THEN
24387 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
24389 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
24390 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
24391 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
24394 IF (ABS(MODE).EQ.3) THEN
24395 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
24396 IF (IREJ1.NE.0) GOTO 9999
24405 *===emc2===============================================================*
24408 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
24411 ************************************************************************
24412 * MODE = 1 energy-momentum cons. check *
24413 * = 2 flavor-cons. check *
24414 * = 3 energy-momentum & flavor cons. check *
24415 * = 4 energy-momentum & charge cons. check *
24416 * = 5 energy-momentum & flavor & charge cons. check *
24417 * This version dated 16.01.95 is written by S. Roesler *
24418 ************************************************************************
24420 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24423 PARAMETER ( LINP = 5 ,
24427 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
24431 PARAMETER (NMXHKK=200000)
24433 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
24434 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
24435 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
24436 * extended event history
24437 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
24438 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
24446 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
24447 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
24448 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24449 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
24450 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
24452 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
24453 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
24454 & (ISTHKK(I).EQ.IP5)) THEN
24455 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
24457 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
24459 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24460 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
24461 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
24462 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
24464 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
24465 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
24466 & (ISTHKK(I).EQ.IN5)) THEN
24467 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
24469 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
24471 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24472 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
24473 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
24474 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
24477 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
24478 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
24479 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
24480 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
24481 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
24482 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
24491 *===evtemc=============================================================*
24493 CDECK ID>, DT_EVTEMC
24494 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
24496 ************************************************************************
24497 * This version dated 13.12.94 is written by S. Roesler *
24498 ************************************************************************
24500 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24503 PARAMETER ( LINP = 5 ,
24507 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
24512 PARAMETER (NMXHKK=200000)
24514 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
24515 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
24516 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
24517 * flags for input different options
24518 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
24519 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
24520 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
24526 IF (MODE.EQ.4) THEN
24529 ELSEIF (MODE.EQ.5) THEN
24532 ELSEIF (MODE.EQ.-1) THEN
24537 IF (ABS(MODE).EQ.3) THEN
24542 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
24543 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
24544 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
24545 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
24546 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
24547 & ' event ',NEVHKK,
24548 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
24562 IF (MODE.EQ.1) THEN
24581 *===evtflc=============================================================*
24583 CDECK ID>, DT_EVTFLC
24584 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
24586 ************************************************************************
24587 * Flavor conservation check. *
24588 * ID identity of particle *
24589 * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
24590 * = 2 ID for particle/resonance in BAMJET numbering scheme *
24591 * = 3 ID for particle/resonance in PDG numbering scheme *
24592 * MODE = 1 initialization and add ID *
24593 * =-1 initialization and subtract ID *
24595 * =-2 subtract ID *
24596 * = 3 check flavor cons. *
24597 * IPOS flag to give position of call of EVTFLC to output *
24598 * unit in case of violation *
24599 * This version dated 10.01.95 is written by S. Roesler *
24600 ************************************************************************
24602 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24605 PARAMETER ( LINP = 5 ,
24609 PARAMETER (TINY10=1.0D-10)
24613 IF (MODE.EQ.3) THEN
24615 WRITE(LOUT,'(1X,A,I3,A,I3)')
24616 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
24625 IF (MODE.EQ.1) IFL = 0
24626 IF (ID.EQ.0) RETURN
24631 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
24632 IF (IDD.GE.1000) NQ = 3
24634 IFBAM = IDT_IPDG2B(ID,I,2)
24635 IF (ABS(IFBAM).EQ.1) THEN
24636 IFBAM = SIGN(2,IFBAM)
24637 ELSEIF (ABS(IFBAM).EQ.2) THEN
24638 IFBAM = SIGN(1,IFBAM)
24640 IF (MODE.GT.0) THEN
24650 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
24651 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
24653 IF (MODE.GT.0) THEN
24654 IFL = IFL+IDT_IQUARK(I,IDD)
24656 IFL = IFL-IDT_IQUARK(I,IDD)
24667 *===evtchg=============================================================*
24669 CDECK ID>, DT_EVTCHG
24670 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
24672 ************************************************************************
24673 * Charge conservation check. *
24674 * ID identity of particle (PDG-numbering scheme) *
24675 * MODE = 1 initialization *
24676 * =-2 subtract ID-charge *
24677 * = 2 add ID-charge *
24678 * = 3 check charge cons. *
24679 * IPOS flag to give position of call of EVTCHG to output *
24680 * unit in case of violation *
24681 * This version dated 10.01.95 is written by S. Roesler *
24682 * Last change: s.r. 21.01.01 *
24683 ************************************************************************
24685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24688 PARAMETER ( LINP = 5 ,
24694 PARAMETER (NMXHKK=200000)
24696 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
24697 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
24698 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
24699 * particle properties (BAMJET index convention)
24701 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24702 & IICH(210),IIBAR(210),K1(210),K2(210)
24706 IF (MODE.EQ.1) THEN
24712 IF (MODE.EQ.3) THEN
24713 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
24714 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
24715 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
24716 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
24726 IF (ID.EQ.0) RETURN
24728 IDD = IDT_ICIHAD(ID)
24729 * modification 21.1.01: use intrinsic phojet-functions to determine charge
24730 * and baryon number
24731 C IF (IDD.GT.0) THEN
24732 C IF (MODE.EQ.2) THEN
24733 C ICH = ICH+IICH(IDD)
24734 C IBAR = IBAR+IIBAR(IDD)
24735 C ELSEIF (MODE.EQ.-2) THEN
24736 C ICH = ICH-IICH(IDD)
24737 C IBAR = IBAR-IIBAR(IDD)
24740 C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
24741 C CALL DT_EVTOUT(4)
24744 IF (MODE.EQ.2) THEN
24745 ICH = ICH+IPHO_CHR3(ID,1)/3
24746 IBAR = IBAR+IPHO_BAR3(ID,1)/3
24747 ELSEIF (MODE.EQ.-2) THEN
24748 ICH = ICH-IPHO_CHR3(ID,1)/3
24749 IBAR = IBAR-IPHO_BAR3(ID,1)/3
24759 ************************************************************************
24761 * 4) Transformations *
24763 ************************************************************************
24765 *===ltini==============================================================*
24767 CDECK ID>, DT_LTINI
24768 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
24770 ************************************************************************
24771 * Initializations of Lorentz-transformations, calculation of Lorentz- *
24773 * This version dated 13.11.95 is written by S. Roesler. *
24774 ************************************************************************
24776 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24779 PARAMETER ( LINP = 5 ,
24783 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
24784 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
24786 * Lorentz-parameters of the current interaction
24787 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
24788 & UMO,PPCM,EPROJ,PPROJ
24789 * properties of photon/lepton projectiles
24790 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
24791 * particle properties (BAMJET index convention)
24793 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24794 & IICH(210),IIBAR(210),K1(210),K2(210)
24795 * nucleon-nucleon event-generator
24798 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
24802 IF (MCGENE.NE.3) THEN
24803 * lepton-projectiles and PHOJET: initialize real photon instead
24804 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
24805 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
24806 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
24815 AMP = AAM(IDP)-SQRT(ABS(Q2))
24817 AMP2 = SIGN(AMP**2,AMP)
24819 IF (ECM0.GT.ZERO) THEN
24820 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
24821 IF (AMP2.GT.ZERO) THEN
24822 PPN = SQRT((EPN+AMP)*(EPN-AMP))
24824 PPN = SQRT(EPN**2-AMP2)
24827 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
24828 IF (IDP.EQ.7) EPN = ABS(EPN)
24829 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
24830 IF (AMP2.GT.ZERO) THEN
24831 PPN = SQRT((EPN+AMP)*(EPN-AMP))
24833 PPN = SQRT(EPN**2-AMP2)
24835 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24836 IF (AMP2.GT.ZERO) THEN
24837 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
24839 EPN = SQRT(PPN**2+AMP2)
24842 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
24847 IF (AMP2.GT.ZERO) THEN
24848 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
24849 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
24854 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
24860 IF (ECM0.GT.ZERO) THEN
24863 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
24864 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
24865 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24866 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
24869 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
24870 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
24871 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
24872 IF (MODE.EQ.1) THEN
24875 PNUCL(3) = -PGAMM(3)
24876 PNUCL(4) = SQRT(S)-PGAMM(4)
24879 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
24880 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
24883 * neglect lepton masses
24884 C AMLPT2 = AAM(IDPR)**2
24887 IF (ECM0.GT.ZERO) THEN
24890 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
24891 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
24892 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24893 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
24896 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
24897 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
24898 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
24901 PNUCL(3) = -PLEPT0(3)
24902 PNUCL(4) = SQRT(S)-PLEPT0(4)
24904 * Lorentz-parameter for transformation Lab. - projectile rest system
24905 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
24914 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
24919 GACMS(1) = (ETARG+AMP)/UMO
24920 BGCMS(1) = PTARG/UMO
24922 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
24923 GACMS(2) = (EPROJ+AMT)/UMO
24924 BGCMS(2) = PPROJ/UMO
24925 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
24934 *===ltrans=============================================================*
24936 CDECK ID>, DT_LTRANS
24937 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
24939 ************************************************************************
24940 * Lorentz-transformations. *
24941 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
24942 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
24943 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
24944 * This version dated 01.11.95 is written by S. Roesler. *
24945 ************************************************************************
24947 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24950 PARAMETER ( LINP = 5 ,
24954 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
24956 PARAMETER (SQTINF=1.0D+15)
24958 * particle properties (BAMJET index convention)
24960 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24961 & IICH(210),IIBAR(210),K1(210),K2(210)
24965 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
24967 * check particle mass for consistency (numerical rounding errors)
24968 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
24969 AMO2 = (PEO-PO)*(PEO+PO)
24970 AMORQ2 = AAM(ID)**2
24971 AMDIF2 = ABS(AMO2-AMORQ2)
24972 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
24973 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
24979 C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
24985 *===ltnuc==============================================================*
24987 CDECK ID>, DT_LTNUC
24988 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
24990 ************************************************************************
24991 * Lorentz-transformations. *
24992 * PIN longitudnal momentum (input) *
24993 * EIN energy (input) *
24994 * POUT transformed long. momentum (output) *
24995 * EOUT transformed energy (output) *
24996 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
24997 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
24998 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
24999 * This version dated 01.11.95 is written by S. Roesler. *
25000 ************************************************************************
25002 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25005 PARAMETER ( LINP = 5 ,
25009 PARAMETER (ZERO=0.0D0)
25011 * Lorentz-parameters of the current interaction
25012 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25013 & UMO,PPCM,EPROJ,PPROJ
25019 IF (ABS(MODE).EQ.1) THEN
25020 BG = -SIGN(BGLAB,DBLE(MODE))
25021 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
25022 & DUM1,DUM2,DUM3,POUT,EOUT)
25023 ELSEIF (ABS(MODE).EQ.2) THEN
25024 BG = SIGN(BGCMS(1),DBLE(MODE))
25025 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
25026 & DUM1,DUM2,DUM3,POUT,EOUT)
25027 ELSEIF (ABS(MODE).EQ.3) THEN
25028 BG = -SIGN(BGCMS(2),DBLE(MODE))
25029 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
25030 & DUM1,DUM2,DUM3,POUT,EOUT)
25032 WRITE(LOUT,1000) MODE
25033 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
25041 *===daltra=============================================================*
25043 CDECK ID>, DT_DALTRA
25044 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
25046 ************************************************************************
25047 * Arbitrary Lorentz-transformation. *
25048 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
25049 ************************************************************************
25051 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25053 PARAMETER (ONE=1.0D0)
25055 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
25056 PE = EP/(GA+ONE)+EC
25060 P = SQRT(PX*PX+PY*PY+PZ*PZ)
25066 *====dtrafo============================================================*
25068 CDECK ID>, DT_DTRAFO
25069 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
25070 & PL,CXL,CYL,CZL,EL)
25072 C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
25074 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25077 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
25078 SID = SQRT(1.D0-COD*COD)
25082 PLZ = GAM*PCMZ+BGAM*ECM
25083 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
25084 EL = GAM*ECM+BGAM*PCMZ
25085 C ROTATION INTO THE ORIGINAL DIRECTION
25087 SIZ = SQRT(1.D0-COZ**2)
25088 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
25093 *====sttran============================================================*
25095 CDECK ID>, DT_STTRAN
25096 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
25098 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25100 DATA ANGLSQ/1.D-30/
25101 ************************************************************************
25102 * VERSION BY J. RANFT *
25105 * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
25107 * INPUT VARIABLES: *
25108 * XO,YO,ZO = ORIGINAL DIRECTION COSINES *
25109 * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
25110 * ANGLE OF "SCATTERING" *
25111 * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
25112 * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
25113 * OF "SCATTERING" *
25115 * OUTPUT VARIABLES: *
25116 * X,Y,Z = NEW DIRECTION COSINES *
25118 * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
25119 ************************************************************************
25122 * Changed by A. Ferrari
25124 * IF (ABS(XO)-0.0001D0) 1,1,2
25125 * 1 IF (ABS(YO)-0.0001D0) 3,3,2
25128 IF ( A .LT. ANGLSQ ) THEN
25137 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
25138 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
25145 *===mytran=============================================================*
25147 CDECK ID>, DT_MYTRAN
25148 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
25150 ************************************************************************
25151 * This subroutine rotates the coordinate frame *
25152 * a) theta around y *
25153 * b) phi around z if IMODE = 1 *
25155 * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
25156 * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
25157 * z' 0 0 1 -sin(th) 0 cos(th) z *
25159 * and vice versa if IMODE = 0. *
25160 * This version dated 5.4.94 is based on the original version DTRAN *
25161 * by J. Ranft and is written by S. Roesler. *
25162 ************************************************************************
25164 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25167 PARAMETER ( LINP = 5 ,
25171 IF (IMODE.EQ.1) THEN
25172 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
25173 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
25174 Z=-SDE *XO +CDE *ZO
25176 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
25178 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
25183 *===lt2lab=============================================================*
25185 CDECK ID>, DT_LT2LAO
25186 SUBROUTINE DT_LT2LAO
25188 ************************************************************************
25189 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
25190 * for final state particles/fragments defined in nucleon-nucleon-cms *
25191 * and transforms them back to the lab. *
25192 * This version dated 16.11.95 is written by S. Roesler *
25193 ************************************************************************
25195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25198 PARAMETER ( LINP = 5 ,
25204 PARAMETER (NMXHKK=200000)
25206 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25207 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25208 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25209 * extended event history
25210 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25211 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25216 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
25217 DO 1 I=NPOINT(4),NEND
25219 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
25220 & (ISTHKK(I).EQ.1001)) THEN
25221 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
25223 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
25224 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
25225 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
25226 ISTHKK(I) = 3*ISTHKK(I)
25229 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
25230 ISTHKK(I) = SIGN(3,ISTHKK(I))
25239 *===lt2lab=============================================================*
25241 CDECK ID>, DT_LT2LAB
25242 SUBROUTINE DT_LT2LAB
25244 ************************************************************************
25245 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
25246 * for final state particles/fragments defined in nucleon-nucleon-cms *
25247 * and transforms them to the lab. *
25248 * This version dated 07.01.96 is written by S. Roesler *
25249 ************************************************************************
25251 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25254 PARAMETER ( LINP = 5 ,
25260 PARAMETER (NMXHKK=200000)
25262 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25263 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25264 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25265 * extended event history
25266 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25267 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25270 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
25271 DO 1 I=NPOINT(4),NHKK
25272 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
25273 & (ISTHKK(I).EQ.1001)) THEN
25274 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
25283 ************************************************************************
25285 * 5) Sampling from distributions *
25287 ************************************************************************
25289 *===npoiss=============================================================*
25291 CDECK ID>, IDT_NPOISS
25292 INTEGER FUNCTION IDT_NPOISS(AVN)
25294 ************************************************************************
25295 * Sample according to Poisson distribution with Poisson parameter AVN. *
25296 * The original version written by J. Ranft. *
25297 * This version dated 11.1.95 is written by S. Roesler. *
25298 ************************************************************************
25300 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25303 PARAMETER ( LINP = 5 ,
25313 IF (A.GE.EXPAVN) THEN
25322 *===sampxb=============================================================*
25324 CDECK ID>, DT_SAMPXB
25325 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
25327 ************************************************************************
25328 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
25329 * Processed by S. Roesler, 6.5.95 *
25330 ************************************************************************
25332 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25334 PARAMETER (TWO=2.0D0)
25336 A1 = LOG(X1+SQRT(X1**2+B**2))
25337 A2 = LOG(X2+SQRT(X2**2+B**2))
25339 A = AN*DT_RNDM(A1)+A1
25341 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
25346 *===sampex=============================================================*
25348 CDECK ID>, DT_SAMPEX
25349 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
25351 ************************************************************************
25352 * Sampling from f(x)=1./x between x1 and x2. *
25353 * Processed by S. Roesler, 6.5.95 *
25354 ************************************************************************
25356 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25358 PARAMETER (ONE=1.0D0)
25363 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
25368 *===samsqx=============================================================*
25370 CDECK ID>, DT_SAMSQX
25371 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
25373 ************************************************************************
25374 * Sampling from f(x)=1./x^0.5 between x1 and x2. *
25375 * Processed by S. Roesler, 6.5.95 *
25376 ************************************************************************
25378 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25380 PARAMETER (ONE=1.0D0)
25383 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
25388 *===samplw=============================================================*
25390 CDECK ID>, DT_SAMPLW
25391 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
25393 ************************************************************************
25394 * Sampling from f(x)=1/x^b between x_min and x_max. *
25395 * S. Roesler, 18.4.98 *
25396 ************************************************************************
25398 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25400 PARAMETER (ONE=1.0D0)
25404 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
25407 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
25413 *===betrej=============================================================*
25415 CDECK ID>, DT_BETREJ
25416 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
25418 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25421 PARAMETER ( LINP = 5 ,
25425 PARAMETER (ONE=1.0D0)
25427 IF (XMIN.GE.XMAX)THEN
25428 WRITE (LOUT,500) XMIN,XMAX
25429 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
25434 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
25435 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
25436 YY = BETMAX*DT_RNDM(XX)
25437 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
25438 IF (YY.GT.BETXX) GOTO 10
25444 *===dgamrn=============================================================*
25446 CDECK ID>, DT_DGAMRN
25447 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
25449 ************************************************************************
25450 * Sampling from Gamma-distribution. *
25451 * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
25452 * Processed by S. Roesler, 6.5.95 *
25453 ************************************************************************
25455 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25457 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
25462 IF (F.EQ.ZERO) GOTO 20
25465 IF (NCOU.GE.11) GOTO 20
25466 IF (R.LT.F/(F+2.71828D0)) GOTO 30
25467 YYY = LOG(DT_RNDM(R)+TINY9)/F
25468 IF (ABS(YYY).GT.50.0D0) GOTO 20
25470 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
25474 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
25475 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
25476 40 IF (N.EQ.0) GOTO 70
25479 60 Z = Z*DT_RNDM(Z)
25481 70 DT_DGAMRN = Y/ALAM
25486 *===dbetar=============================================================*
25488 CDECK ID>, DT_DBETAR
25489 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
25491 ************************************************************************
25492 * Sampling from Beta -distribution between 0.0 and 1.0 *
25493 * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
25494 * Processed by S. Roesler, 6.5.95 *
25495 ************************************************************************
25497 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25500 Y = DT_DGAMRN(1.0D0,GAM)
25501 Z = DT_DGAMRN(1.0D0,ETA)
25502 DT_DBETAR = Y/(Y+Z)
25507 *===rannor=============================================================*
25509 CDECK ID>, DT_RANNOR
25510 SUBROUTINE DT_RANNOR(X,Y)
25512 ************************************************************************
25513 * Sampling from Gaussian distribution. *
25514 * Processed by S. Roesler, 6.5.95 *
25515 ************************************************************************
25517 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25519 PARAMETER (TINY10=1.0D-10)
25521 CALL DT_DSFECF(SFE,CFE)
25522 V = MAX(TINY10,DT_RNDM(X))
25523 A = SQRT(-2.D0*LOG(V))
25530 *===dpoli==============================================================*
25532 CDECK ID>, DT_DPOLI
25533 SUBROUTINE DT_DPOLI(CS,SI)
25535 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25540 IF (U.LT.0.5D0) CS=-CS
25541 SI = SQRT(1.0D0-CS*CS+1.0D-10)
25546 *===dsfecf=============================================================*
25548 CDECK ID>, DT_DSFECF
25549 SUBROUTINE DT_DSFECF(SFE,CFE)
25551 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25553 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
25561 IF (XY.GT.ONE) GOTO 1
25564 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
25568 *===raco===============================================================*
25571 SUBROUTINE DT_RACO(WX,WY,WZ)
25573 ************************************************************************
25574 * Direction cosines of random uniform (isotropic) direction in three *
25575 * dimensional space *
25576 * Processed by S. Roesler, 20.11.95 *
25577 ************************************************************************
25579 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25581 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
25584 X = TWO*DT_RNDM(WX)-ONE
25588 IF (X2+Y2.GT.ONE) GOTO 10
25590 CFE = (X2-Y2)/(X2+Y2)
25591 SFE = TWO*X*Y/(X2+Y2)
25592 * z = 1/2 [ 1 + cos (theta) ]
25595 WZ = SQRT(Z*(ONE-Z))
25603 ************************************************************************
25605 * 6) Special functions, algorithms and service routines *
25607 ************************************************************************
25609 *===ylamb==============================================================*
25611 CDECK ID>, DT_YLAMB
25612 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
25614 ************************************************************************
25616 * auxiliary function for three particle decay mode *
25617 * (standard LAMBDA**(1/2) function) *
25619 * Adopted from an original version written by R. Engel. *
25620 * This version dated 12.12.94 is written by S. Roesler. *
25621 ************************************************************************
25623 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25627 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
25628 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
25629 DT_YLAMB = SQRT(XLAM)
25634 *===sort1==============================================================*
25637 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
25639 ************************************************************************
25640 * This subroutine sorts entries in A in increasing/decreasing order *
25642 * MODE = 1 increasing in A(3,i=1..N) *
25643 * = 2 decreasing in A(3,i=1..N) *
25644 * This version dated 21.04.95 is revised by S. Roesler *
25645 ************************************************************************
25647 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25659 IF (MODE.EQ.1) THEN
25660 IF (A(3,I).LE.A(3,J)) GOTO 20
25662 IF (A(3,I).GE.A(3,J)) GOTO 20
25675 IF (L.EQ.1) GOTO 10
25680 *===sort1==============================================================*
25682 CDECK ID>, DT_SORT1
25683 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
25685 ************************************************************************
25686 * This subroutine sorts entries in A in increasing/decreasing order *
25688 * MODE = 1 increasing in A(i=1..N) *
25689 * = 2 decreasing in A(i=1..N) *
25690 * This version dated 21.04.95 is revised by S. Roesler *
25691 ************************************************************************
25693 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25696 DIMENSION A(N),IDX(N)
25705 IF (MODE.EQ.1) THEN
25706 IF (A(I).LE.A(J)) GOTO 20
25708 IF (A(I).GE.A(J)) GOTO 20
25718 IF (L.EQ.1) GOTO 10
25723 *===xtime==============================================================*
25725 CDECK ID>, DT_XTIME
25726 SUBROUTINE DT_XTIME
25728 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25731 PARAMETER ( LINP = 5 ,
25735 CHARACTER DAT*9,TIM*11
25739 C CALL GETDAT(IYEAR,IMONTH,IDAY)
25740 C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
25744 C WRITE(LOUT,1000) DAT,TIM
25745 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
25750 ************************************************************************
25752 * 7) Random number generator package *
25754 * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
25755 * SERVICE ROUTINES. *
25756 * THE ALGORITHM IS FROM *
25757 * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
25758 * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
25759 * IMPLEMENTATION BY K. HAHN DEC. 88, *
25760 * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
25761 * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
25762 * THE PERIOD IS ABOUT 2**144, *
25763 * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
25764 * THE PACKAGE CONTAINS *
25765 * FUNCTION DT_RNDM(I) : GENERATOR *
25766 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
25767 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
25768 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
25769 * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
25771 * FUNCTION DT_RNDM(I) *
25772 * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
25773 * I - DUMMY VARIABLE, NOT USED *
25774 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
25775 * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
25776 * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
25777 * NA? MUST BE IN 1..178 AND NOT ALL 1 *
25778 * 12,34,56 ARE THE STANDARD VALUES *
25779 * NB1 MUST BE IN 1..168 *
25780 * 78 IS THE STANDARD VALUE *
25781 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
25782 * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
25783 * AS AFTER THE LAST DT_RNDMOU CALL ) *
25784 * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
25785 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
25786 * TAKES SEED FROM GENERATOR *
25787 * U(97),C,CD,CM,I,J - SEED VALUES *
25788 * SUBROUTINE DT_RNDMTE(IO) *
25789 * TEST OF THE GENERATOR *
25790 * IO - DEFINES OUTPUT *
25791 * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
25792 * = 1 OUTPUT INDEPENDEND ON AN ERROR *
25793 * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
25795 * AS BEFORE CALL OF DT_RNDMTE *
25796 ************************************************************************
25798 *===rndm===============================================================*
25801 DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
25803 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25806 * counter of calls to random number generator
25807 * uncomment if needed
25808 C COMMON /DTRNCT/ IRNCT0,IRNCT1
25810 C DATA LFIRST /.TRUE./
25812 * counter of calls to random number generator
25813 * uncomment if needed
25820 DT_RNDM = FLRNDM(VDUMMY)
25821 * counter of calls to random number generator
25822 * uncomment if needed
25823 C IRNCT1 = IRNCT1+1
25828 *===rndmst=============================================================*
25830 CDECK ID>, DT_RNDMST
25831 SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
25833 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25836 * random number generator
25837 COMMON /DTRAND/ U(97),C,CD,CM,I,J
25849 MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
25853 MB1 = MOD(53*MB1+1,169)
25854 IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
25857 C = 362436.0D0/16777216.0D0
25858 CD = 7654321.0D0/16777216.0D0
25859 CM = 16777213.0D0/16777216.0D0
25863 *===rndmin=============================================================*
25865 CDECK ID>, DT_RNDMIN
25866 SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
25868 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25871 * random number generator
25872 COMMON /DTRAND/ U(97),C,CD,CM,I,J
25877 10 U(KKK) = UIN(KKK)
25887 *===rndmou=============================================================*
25889 CDECK ID>, DT_RNDMOU
25890 SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
25892 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25895 * random number generator
25896 COMMON /DTRAND/ U(97),C,CD,CM,I,J
25901 10 UOUT(KKK) = U(KKK)
25911 *===rndmte=============================================================*
25913 CDECK ID>, DT_RNDMTE
25914 SUBROUTINE DT_RNDMTE(IO)
25916 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25919 DIMENSION UU(97),U(6),X(6),D(6)
25920 DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
25921 +8354498.D0, 10633180.D0/
25923 CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
25924 CALL DT_RNDMST(12,34,56,78)
25925 DO 10 II1 = 1,20000
25926 10 XX = DT_RNDM(XX)
25929 X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
25930 D(II2) = X(II2)-U(II2)
25932 CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
25934 C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
25935 IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
25937 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
25942 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
25943 &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
25944 &1,F20.1,F15.3,/), ' === END OF TEST ;',
25945 &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
25949 *===title==============================================================*
25951 CDECK ID>, DT_TITLE
25952 SUBROUTINE DT_TITLE
25954 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25957 PARAMETER ( LINP = 5 ,
25962 CHARACTER*11 CCHANG
25963 DATA CVERSI,CCHANG /'3.0-4 ','18 Sep 2001'/
25966 WRITE(LOUT,1000) CVERSI,CCHANG
25967 1000 FORMAT(1X,'+-------------------------------------------------',
25968 & '----------------------+',/,
25969 & 1X,'|',71X,'|',/,
25970 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
25971 & 1X,'|',71X,'|',/,
25972 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
25973 & 1X,'|',71X,'|',/,
25974 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
25975 & 1X,'|',21X,'Ralph Engel (Bartol Res. Inst.)',14X,'|',/,
25976 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
25977 & 1X,'|',71X,'|',/,
25978 & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
25980 & 1X,'|',71X,'|',/,
25981 & 1X,'+-------------------------------------------------',
25982 & '----------------------+',/,
25983 & 1X,'| Please send suggestions, bug reports, etc. to: ',
25984 & 'Stefan.Roesler@cern.ch |',/,
25985 & 1X,'+-------------------------------------------------',
25986 & '----------------------+',/)
25991 *===evtini=============================================================*
25993 CDECK ID>, DT_EVTINI
25994 SUBROUTINE DT_EVTINI
25996 ************************************************************************
25997 * Initialization of DTEVT1. *
25998 * This version dated 15.01.94 is written by S. Roesler *
25999 ************************************************************************
26001 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26004 PARAMETER ( LINP = 5 ,
26010 PARAMETER (NMXHKK=200000)
26012 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26013 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26014 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26015 * extended event history
26016 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26017 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26020 COMMON /DTEVNO/ NEVENT,ICASCA
26022 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
26024 * emulsion treatment
26025 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
26028 * initialization of DTEVT1/DTEVT2
26030 IF (NEVENT.EQ.1) NEND = NMXHKK
26058 C* initialization of DTLTRA
26059 C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
26064 *===statis=============================================================*
26066 CDECK ID>, DT_STATIS
26067 SUBROUTINE DT_STATIS(MODE)
26069 ************************************************************************
26070 * Initialization and output of run-statistics. *
26071 * MODE = 1 initialization *
26073 * This version dated 23.01.94 is written by S. Roesler *
26074 ************************************************************************
26076 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26079 PARAMETER ( LINP = 5 ,
26083 PARAMETER (TINY3=1.0D-3)
26086 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
26087 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
26089 * rejection counter
26090 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
26091 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
26092 & IREXCI(3),IRDIFF(2),IRINC
26093 * central particle production, impact parameter biasing
26094 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
26095 * various options for treatment of partons (DTUNUC 1.x)
26096 * (chain recombination, Cronin,..)
26097 LOGICAL LCO2CR,LINTPT
26098 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
26100 * nucleon-nucleon event-generator
26103 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26104 * flags for particle decays
26105 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
26106 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
26107 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
26108 * diquark-breaking mechanism
26109 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
26111 DIMENSION PP(4),PT(4)
26118 * initialize statistics counter
26131 * initialize rejection counter
26162 * statistics counter
26164 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
26165 & 28X,'---------------------')
26166 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
26167 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
26168 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
26169 & 'event',11X,F9.1)
26170 IF (ICDIFF(1).NE.0) THEN
26171 WRITE(LOUT,1009) ICDIFF
26172 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
26173 & 'low mass high mass',/,24X,'single diffraction',
26174 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
26176 IF (ICENTR.GT.0) THEN
26177 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
26178 & DBLE(ICSAMP)/DBLE(ICCPRO)
26179 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
26180 & ' of sampled Glauber-events per event',9X,F9.1,/,
26181 & 2X,'fraction of production cross section',21X,F10.6)
26183 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
26184 & DBLE(ICDTA)/DBLE(ICSAMP)
26185 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
26186 & ' nucleons after x-sampling',2(4X,F6.2))
26188 IF (MCGENE.EQ.1) THEN
26189 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
26190 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
26191 & ' event',3X,F9.1)
26192 IF (ISICHA.EQ.1) THEN
26193 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
26194 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
26195 & 'of single chains per event',13X,F9.1)
26198 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
26199 & 23X,'mean number of chains mean number of chains',/,
26200 & 23X,'sampled hadronized having mass of a reso.')
26201 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
26202 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
26203 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
26204 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
26205 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26206 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26207 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26208 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26209 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26210 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26211 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26212 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
26213 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
26215 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
26216 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
26217 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
26218 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
26219 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
26220 & DBLE(IRHHA)/DBLE(ICREQU),
26221 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
26222 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
26223 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
26224 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
26225 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
26226 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
26227 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
26228 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
26229 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
26230 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
26231 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
26232 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
26233 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
26234 & F7.2,/,1X,'Total no. of rej.',
26235 & ' in chain-systems treatment (GETCSY)',/,43X,
26236 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
26237 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
26238 & 1X,'Total no. of rej. in DPM-treatment of one event',
26239 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
26240 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
26241 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
26242 & 'IREXCI(3) = ',I5,/)
26243 ELSEIF (MCGENE.EQ.2) THEN
26244 C *** Commented by Chiara
26245 C WRITE(LOUT,1010) ELOJET
26246 C 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
26249 C 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
26250 C & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
26251 C & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
26252 C WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
26253 C & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
26254 C & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
26255 C & ((ICEVTG(I,J),I=1,8),J=3,7),
26256 C & ((ICEVTG(I,J),I=1,8),J=19,21),
26257 C & (ICEVTG(I,8),I=1,8),
26258 C & ((ICEVTG(I,J),I=1,8),J=22,24),
26259 C & (ICEVTG(I,9),I=1,8),
26260 C & ((ICEVTG(I,J),I=1,8),J=25,28),
26261 C & ((ICEVTG(I,J),I=1,8),J=10,18)
26262 C 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
26263 C & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
26264 C & ' no-dif.',8I8,/,
26265 C & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
26266 C & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
26267 C & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
26268 C & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
26269 C & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
26270 C & ' hi-lo ',8I8,/,
26271 C & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
26272 C & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
26273 C & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
26275 C 1013 FORMAT(/,1X,'2. chain system statistics -',
26276 C & ' mean numbers per evt:',/,30X,'---------------------',
26277 C & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
26279 C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
26280 C & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
26281 C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
26282 C 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
26283 C & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
26284 C & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
26285 C & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
26286 C & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
26287 C & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
26288 C & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
26289 C & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
26290 C & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
26291 C & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
26293 C 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
26295 C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
26296 C & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
26297 C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
26298 C 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
26299 C & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
26300 C & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
26301 C & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
26302 C & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
26303 C & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
26304 C & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
26305 C & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
26306 C & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
26307 C & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
26312 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
26313 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
26314 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
26315 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
26316 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
26317 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
26318 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
26319 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
26320 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
26321 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
26322 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
26323 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
26324 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
26325 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
26326 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
26327 & DBRKA(3,1),DBRKA(3,2),
26328 & DBRKA(3,3),DBRKA(3,4)
26329 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
26330 & DBRKR(3,1),DBRKR(3,2),
26331 & DBRKR(3,3),DBRKR(3,4)
26332 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
26333 & DBRKA(3,5),DBRKA(3,6),
26334 & DBRKA(3,7),DBRKA(3,8)
26335 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
26336 & DBRKR(3,5),DBRKR(3,6),
26337 & DBRKR(3,7),DBRKR(3,8)
26341 IF (MCGENE.EQ.2) THEN
26343 C CALL PHO_PHIST(-2,SIGMAX)
26344 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
26353 *===evtout=============================================================*
26355 CDECK ID>, DT_EVTOUT
26356 SUBROUTINE DT_EVTOUT(MODE)
26358 ************************************************************************
26359 * MODE = 1 plot content of complete DTEVT1 to out. unit *
26360 * 3 plot entries of extended DTEVT1 (DTEVT2) *
26361 * 4 plot entries of DTEVT1 and DTEVT2 *
26362 * This version dated 11.12.94 is written by S. Roesler *
26363 ************************************************************************
26365 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26368 PARAMETER ( LINP = 5 ,
26374 PARAMETER (NMXHKK=200000)
26376 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26377 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26378 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26380 DIMENSION IRANGE(NMXHKK)
26382 IF (MODE.EQ.2) RETURN
26384 CALL DT_EVTPLO(IRANGE,MODE)
26389 *===evtplo=============================================================*
26391 CDECK ID>, DT_EVTPLO
26392 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
26394 ************************************************************************
26395 * MODE = 1 plot content of complete DTEVT1 to out. unit *
26396 * 2 plot entries of DTEVT1 given by IRANGE *
26397 * 3 plot entries of extended DTEVT1 (DTEVT2) *
26398 * 4 plot entries of DTEVT1 and DTEVT2 *
26399 * 5 plot rejection counter *
26400 * This version dated 11.12.94 is written by S. Roesler *
26401 ************************************************************************
26403 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26406 PARAMETER ( LINP = 5 ,
26414 PARAMETER (NMXHKK=200000)
26416 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26417 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26418 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26419 * extended event history
26420 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26421 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26423 * rejection counter
26424 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
26425 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
26426 & IREXCI(3),IRDIFF(2),IRINC
26428 DIMENSION IRANGE(NMXHKK)
26430 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
26432 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
26433 & 15X,' --------------------------',/,/,
26434 & ' ST ID M1 M2 D1 D2 PX PY',
26437 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26438 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26439 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
26441 C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26442 C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26443 C & PHKK(3,I),PHKK(4,I)
26444 C WRITE(LOUT,'(4E15.4)')
26445 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
26446 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
26447 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
26451 C WRITE(LOUT,1006) I,ISTHKK(I),
26452 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
26453 C & WHKK(2,I),WHKK(3,I)
26454 C1006 FORMAT(1X,I4,I6,6E10.3)
26458 IF (MODE.EQ.2) THEN
26463 IF (IRANGE(NC).EQ.-100) GOTO 9999
26465 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26466 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26467 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
26472 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
26474 1002 FORMAT(/,1X,'EVTPLO:',14X,
26475 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
26476 & 15X,' -----------------------------------',/,/,
26477 & ' ST ID M1 M2 D1 D2 IDR IDXR',
26478 & ' NOBAM IDCH M',/)
26480 C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
26483 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
26484 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
26486 CALL PYNAME(KF,CHAU)
26488 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26489 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26490 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
26492 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
26497 IF (MODE.EQ.5) THEN
26499 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
26500 & 15X,' --------------------------',/)
26501 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
26503 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
26504 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
26505 & 1X,'IREMC = ',10I5,/,
26506 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
26512 *===evtput=============================================================*
26514 CDECK ID>, DT_EVTPUT
26515 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
26517 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26520 PARAMETER ( LINP = 5 ,
26524 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
26525 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
26529 PARAMETER (NMXHKK=200000)
26531 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26532 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26533 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26534 * extended event history
26535 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26536 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26538 * Lorentz-parameters of the current interaction
26539 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26540 & UMO,PPCM,EPROJ,PPROJ
26541 * particle properties (BAMJET index convention)
26543 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26544 & IICH(210),IIBAR(210),K1(210),K2(210)
26546 C IF (MODE.GT.100) THEN
26547 C WRITE(LOUT,'(1X,A,I5,A,I5)')
26548 C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
26549 C NHKK = NHKK-MODE+100
26556 IF (NHKK.GT.NMXHKK) THEN
26557 WRITE(LOUT,1000) NHKK
26558 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
26559 & '! program execution stopped..')
26562 IF (M1.LT.0) MO1 = NHKK+M1
26563 IF (M2.LT.0) MO2 = NHKK+M2
26566 JMOHKK(1,NHKK) = MO1
26567 JMOHKK(2,NHKK) = MO2
26571 IDXRES(NHKK) = IDXR
26573 ** here we need to do something..
26574 IF (ID.EQ.88888) THEN
26575 IDMO1 = ABS(IDHKK(MO1))
26576 IDMO2 = ABS(IDHKK(MO2))
26577 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
26578 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
26579 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
26580 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
26584 IDBAM(NHKK) = IDT_ICIHAD(ID)
26586 IF (JDAHKK(1,MO1).NE.0) THEN
26587 JDAHKK(2,MO1) = NHKK
26589 JDAHKK(1,MO1) = NHKK
26593 IF (JDAHKK(1,MO2).NE.0) THEN
26594 JDAHKK(2,MO2) = NHKK
26596 JDAHKK(1,MO2) = NHKK
26599 C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
26600 C PTOT = SQRT(PX**2+PY**2+PZ**2)
26601 C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
26602 C AMRQ = AAM(IDBAM(NHKK))
26603 C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
26604 C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
26605 C & (PTOT.GT.ZERO)) THEN
26606 C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
26607 CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
26609 C PTOT1 = PTOT-DELTA
26610 C PX = PX*PTOT1/PTOT
26611 C PY = PY*PTOT1/PTOT
26612 C PZ = PZ*PTOT1/PTOT
26619 PTOT = SQRT( PX**2+PY**2+PZ**2 )
26620 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
26621 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
26622 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
26624 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
26625 C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
26626 C & WRITE(LOUT,'(1X,A,G10.3)')
26627 C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
26628 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
26631 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
26632 * special treatment for chains:
26633 * z coordinate of chain in Lab = pos. of target nucleon
26634 * time of chain-creation in Lab = time of passage of projectile
26635 * nucleus at pos. of taget nucleus
26636 C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
26637 C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
26638 VHKK(1,NHKK) = VHKK(1,MO2)
26639 VHKK(2,NHKK) = VHKK(2,MO2)
26640 VHKK(3,NHKK) = VHKK(3,MO2)
26641 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
26642 C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
26643 C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
26644 WHKK(1,NHKK) = WHKK(1,MO1)
26645 WHKK(2,NHKK) = WHKK(2,MO1)
26646 WHKK(3,NHKK) = WHKK(3,MO1)
26647 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
26651 VHKK(I,NHKK) = VHKK(I,MO1)
26652 WHKK(I,NHKK) = WHKK(I,MO1)
26656 VHKK(I,NHKK) = ZERO
26657 WHKK(I,NHKK) = ZERO
26665 *===chasta=============================================================*
26667 CDECK ID>, DT_CHASTA
26668 SUBROUTINE DT_CHASTA(MODE)
26670 ************************************************************************
26671 * This subroutine performs CHAin STAtistics and checks sequence of *
26672 * partons in dtevt1 and sorts them with projectile partons coming *
26673 * first if necessary. *
26675 * This version dated 8.5.00 is written by S. Roesler. *
26676 ************************************************************************
26678 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26681 PARAMETER ( LINP = 5 ,
26689 PARAMETER (NMXHKK=200000)
26691 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26692 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26693 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26694 * extended event history
26695 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26696 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26698 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
26699 PARAMETER (MAXCHN=10000)
26700 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
26702 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
26703 & CCHTYP(9),ICHSTA(10),ITOT(10)
26704 DATA ICHCFG /1800*0/
26705 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
26706 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
26707 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
26708 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
26709 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
26710 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
26711 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
26712 & 'ad aq',' d ad','ad d ',' g g '/
26716 IF (MODE.EQ.-1) THEN
26719 * loop over DTEVT1 and analyse chain configurations
26721 ELSEIF (MODE.EQ.0) THEN
26722 DO 21 IDX=NPOINT(3),NHKK
26723 IDCHK = IDHKK(IDX)/10000
26724 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
26725 & (IDHKK(IDX).NE.80000).AND.
26726 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
26727 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
26728 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
26733 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
26734 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
26736 IMO1 = IST1-10*IMO1
26738 IMO2 = IST2-10*IMO2
26739 * swop parton entries if necessary since we need projectile partons
26740 * to come first in the common
26741 IF (IMO1.GT.IMO2) THEN
26742 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
26744 I0 = JMOHKK(1,IDX)-1+K
26745 I1 = JMOHKK(2,IDX)+1-K
26747 ISTHKK(I0) = ISTHKK(I1)
26750 IDHKK(I0) = IDHKK(I1)
26752 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
26753 & JDAHKK(1,JMOHKK(1,I0)) = I1
26754 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
26755 & JDAHKK(2,JMOHKK(1,I0)) = I1
26756 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
26757 & JDAHKK(1,JMOHKK(2,I0)) = I1
26758 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
26759 & JDAHKK(2,JMOHKK(2,I0)) = I1
26760 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
26761 & JDAHKK(1,JMOHKK(1,I1)) = I0
26762 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
26763 & JDAHKK(2,JMOHKK(1,I1)) = I0
26764 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
26765 & JDAHKK(1,JMOHKK(2,I1)) = I0
26766 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
26767 & JDAHKK(2,JMOHKK(2,I1)) = I0
26768 ITMP = JMOHKK(1,I0)
26769 JMOHKK(1,I0) = JMOHKK(1,I1)
26770 JMOHKK(1,I1) = ITMP
26771 ITMP = JMOHKK(2,I0)
26772 JMOHKK(2,I0) = JMOHKK(2,I1)
26773 JMOHKK(2,I1) = ITMP
26774 ITMP = JDAHKK(1,I0)
26775 JDAHKK(1,I0) = JDAHKK(1,I1)
26776 JDAHKK(1,I1) = ITMP
26777 ITMP = JDAHKK(2,I0)
26778 JDAHKK(2,I0) = JDAHKK(2,I1)
26779 JDAHKK(2,I1) = ITMP
26784 PHKK(J,I0) = PHKK(J,I1)
26785 VHKK(J,I0) = VHKK(J,I1)
26786 WHKK(J,I0) = WHKK(J,I1)
26792 PHKK(5,I0) = PHKK(5,I1)
26795 IDRES(I0) = IDRES(I1)
26798 IDXRES(I0) = IDXRES(I1)
26801 NOBAM(I0) = NOBAM(I1)
26804 IDBAM(I0) = IDBAM(I1)
26807 IDCH(I0) = IDCH(I1)
26810 IHIST(1,I0) = IHIST(1,I1)
26813 IHIST(2,I0) = IHIST(2,I1)
26817 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
26818 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
26820 * parton 1 (projectile side)
26821 IF (IST1.EQ.21) THEN
26823 ELSEIF (IST1.EQ.22) THEN
26825 ELSEIF (IST1.EQ.31) THEN
26827 ELSEIF (IST1.EQ.32) THEN
26829 ELSEIF (IST1.EQ.41) THEN
26831 ELSEIF (IST1.EQ.42) THEN
26833 ELSEIF (IST1.EQ.51) THEN
26835 ELSEIF (IST1.EQ.52) THEN
26837 ELSEIF (IST1.EQ.61) THEN
26839 ELSEIF (IST1.EQ.62) THEN
26843 c & ' CHASTA: unknown parton status flag (',
26844 c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26847 ID = IDHKK(JMOHKK(1,IDX))
26848 IF (ABS(ID).LE.4) THEN
26854 ELSEIF (ABS(ID).GE.1000) THEN
26860 ELSEIF (ID.EQ.21) THEN
26864 & ' CHASTA: inconsistent parton identity (',
26865 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26869 * parton 2 (target side)
26870 IF (IST2.EQ.21) THEN
26872 ELSEIF (IST2.EQ.22) THEN
26874 ELSEIF (IST2.EQ.31) THEN
26876 ELSEIF (IST2.EQ.32) THEN
26878 ELSEIF (IST2.EQ.41) THEN
26880 ELSEIF (IST2.EQ.42) THEN
26882 ELSEIF (IST2.EQ.51) THEN
26884 ELSEIF (IST2.EQ.52) THEN
26886 ELSEIF (IST2.EQ.61) THEN
26888 ELSEIF (IST2.EQ.62) THEN
26892 c & ' CHASTA: unknown parton status flag (',
26893 c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
26896 ID = IDHKK(JMOHKK(2,IDX))
26897 IF (ABS(ID).LE.4) THEN
26903 ELSEIF (ABS(ID).GE.1000) THEN
26909 ELSEIF (ID.EQ.21) THEN
26913 & ' CHASTA: inconsistent parton identity (',
26914 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26919 ITYPE = ICHTYP(ITYP1,ITYP2)
26920 IF (ITYPE.NE.0) THEN
26921 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
26922 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
26923 ICHCFG(IDX1,IDX2,ITYPE,2) =
26924 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
26927 IF (NCHAIN.GT.MAXCHN) THEN
26928 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
26932 IDXCHN(1,NCHAIN) = IDX
26933 IDXCHN(2,NCHAIN) = ITYPE
26936 & ' CHASTA: inconsistent chain at entry ',IDX
26942 * write statistics to output unit
26944 ELSEIF (MODE.EQ.1) THEN
26945 C *** Commented by Chiara
26946 C WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
26948 C WRITE(LOUT,'(/,2A)')
26949 C & ' -----------------------------------------',
26950 C & '------------------------------------'
26951 C WRITE(LOUT,'(2A)')
26952 C & ' p\\t 21 22 31 32 41',
26953 C & ' 42 51 52 61 62'
26954 C WRITE(LOUT,'(2A)')
26955 C & ' -----------------------------------------',
26956 C & '------------------------------------'
26960 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
26963 C *** Commented by Chiara
26964 c WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
26968 ISUM = ISUM+ICHCFG(I,J,K,1)
26970 C *** Commented by Chiara
26972 C & WRITE(LOUT,'(1X,A5,2X,10I7)')
26973 C & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
26975 C WRITE(LOUT,'(2A)')
26976 C & ' -----------------------------------------',
26977 C & '-------------------------------'
26981 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
26988 *===pohist=============================================================*
26991 CDECK ID>, PHO_PHIST
26992 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
26994 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
26997 PARAMETER ( LINP = 5 ,
27001 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27003 * Glauber formalism: cross sections
27004 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
27005 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
27006 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
27007 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
27008 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
27009 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
27010 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
27011 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
27012 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
27013 & BSLOPE,NEBINI,NQBINI
27016 IF (IMODE.EQ.10) THEN
27020 IF (ABS(IMODE).LT.1000) THEN
27021 * PHOJET-statistics
27022 C CALL POHISX(IMODE,WEIGHT)
27023 IF (IMODE.EQ.-1) THEN
27025 XSTOT(1,1,1) = WEIGHT
27027 IF (IMODE.EQ. 1) MODE = 2
27028 IF (IMODE.EQ.-2) MODE = 3
27029 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
27030 C IF (MODE.EQ.3) WRITE(LOUT,*)
27031 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
27032 CALL DT_HISTOG(MODE)
27033 CALL DT_USRHIS(MODE)
27035 * DTUNUC-statistics
27037 C IF (MODE.EQ.3) WRITE(LOUT,*)
27038 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
27039 CALL DT_HISTOG(MODE)
27040 CALL DT_USRHIS(MODE)
27046 *===swppho=============================================================*
27048 CDECK ID>, DT_SWPPHO
27049 SUBROUTINE DT_SWPPHO(ILAB)
27051 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
27054 PARAMETER ( LINP = 5 ,
27058 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27064 PARAMETER (NMXHKK=200000)
27066 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27067 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27068 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27069 * extended event history
27070 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27071 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27073 * flags for input different options
27074 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
27075 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
27076 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
27077 * properties of photon/lepton projectiles
27078 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
27081 C PARAMETER (NMXHEP=2000)
27082 C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27083 C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
27084 C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27085 C COMMON /PLASAV/ PLAB
27088 C standard particle data interface
27091 PARAMETER (NMXHEP=4000)
27093 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27094 DOUBLE PRECISION PHEP,VHEP
27095 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27096 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27098 C extension to standard particle data interface (PHOJET specific)
27099 INTEGER IMPART,IPHIST,ICOLOR
27100 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27102 C global event kinematics and particle IDs
27103 INTEGER IFPAP,IFPAB
27104 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27105 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27109 DATA LSTART /.TRUE./
27111 C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
27112 IF ((IFRAME.EQ.1).AND.LSTART) THEN
27116 IDP = IDT_ICIHAD(IFPAP(1))
27117 IDT = IDT_ICIHAD(IFPAP(2))
27119 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
27128 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
27130 IF (ISTHEP(I).EQ.1) THEN
27133 IDHKK(NHKK) = IDHEP(I)
27139 PHKK(K,NHKK) = PHEP(K,I)
27140 VHKK(K,NHKK) = ZERO
27141 WHKK(K,NHKK) = ZERO
27143 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
27144 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
27145 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
27146 PHKK(5,NHKK) = PHEP(5,I)
27150 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
27158 *===histog=============================================================*
27160 CDECK ID>, DT_HISTOG
27161 SUBROUTINE DT_HISTOG(MODE)
27163 ************************************************************************
27164 * This version dated 25.03.96 is written by S. Roesler *
27165 ************************************************************************
27167 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27170 PARAMETER ( LINP = 5 ,
27178 PARAMETER (NMXHKK=200000)
27180 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27181 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27182 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27183 * extended event history
27184 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27185 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27187 * event flag used for histograms
27188 COMMON /DTNORM/ ICEVT,IEVHKK
27189 * flags for activated histograms
27190 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
27195 *------------------------------------------------------------------
27199 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
27200 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
27203 *------------------------------------------------------------------
27204 * filling of histogram with event-record
27209 CALL DT_SWPFSP(I,LFSP,LRNL)
27211 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
27212 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
27214 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
27216 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
27219 *------------------------------------------------------------------
27222 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
27223 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
27228 *===swpfsp=============================================================*
27230 CDECK ID>, DT_SWPFSP
27231 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
27233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27235 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27236 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
27238 & BOG =TWOPI/360.0D0)
27242 PARAMETER (NMXHKK=200000)
27244 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27245 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27246 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27247 * extended event history
27248 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27249 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27251 * particle properties (BAMJET index convention)
27253 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27254 & IICH(210),IIBAR(210),K1(210),K2(210)
27255 * Lorentz-parameters of the current interaction
27256 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27257 & UMO,PPCM,EPROJ,PPROJ
27258 * flags for input different options
27259 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
27260 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
27261 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
27266 * temporary storage for one final state particle
27267 LOGICAL LFRAG,LGREY,LBLACK
27268 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
27269 & SINTHE,COSTHE,THETA,THECMS,
27270 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
27271 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
27272 & LFRAG,LGREY,LBLACK
27280 IF (LEVPRT) ISTRNL = 1001
27282 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
27286 IF (IDHKK(IDX).LT.80000) THEN
27288 IBARY = IIBAR(IDBJT)
27289 ICHAR = IICH(IDBJT)
27291 ELSEIF (IDHKK(IDX).EQ.80000) THEN
27294 ICHAR = IDXRES(IDX)
27295 AMASS = PHKK(5,IDX)
27297 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
27298 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
27299 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
27300 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
27301 IF (IDBJT.EQ.0) LFRAG = .TRUE.
27311 PTOT = SQRT(PT2+PZ**2)
27312 SINTHE = PT/MAX(PTOT,TINY14)
27313 COSTHE = PZ/MAX(PTOT,TINY14)
27314 IF (COSTHE.GT.ONE) THEN
27316 ELSEIF (COSTHE.LT.-ONE) THEN
27317 THETA = TWOPI/2.0D0
27319 THETA = ACOS(COSTHE)
27322 **sr 15.4.96 new E_t-definition
27323 IF (IBARY.GT.0) THEN
27325 ELSEIF (IBARY.LT.0) THEN
27326 ET = (EKIN+TWO*AMASS)*SINTHE
27331 XLAB = PZ/MAX(PPROJ,TINY14)
27332 C XLAB = PE/MAX(EPROJ,TINY14)
27333 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
27334 & *(ONE+AMASS/MAX(PE,TINY14)) ))
27337 IF (PMINUS.GT.TINY14) THEN
27338 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
27342 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
27343 ETA = -LOG(TAN(THETA/TWO))
27347 IF (IFRAME.EQ.1) THEN
27348 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
27349 PPLUS = EECMS+PZCMS
27350 PMINUS = EECMS-PZCMS
27351 IF ((PPLUS*PMINUS).GT.TINY14) THEN
27352 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
27356 PTOTCM = SQRT(PT2+PZCMS**2)
27357 COSTH = PZCMS/MAX(PTOTCM,TINY14)
27358 IF (COSTH.GT.ONE) THEN
27360 ELSEIF (COSTH.LT.-ONE) THEN
27361 THECMS = TWOPI/2.0D0
27363 THECMS = ACOS(COSTH)
27365 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
27366 ETACMS = -LOG(TAN(THECMS/TWO))
27370 XF = PZCMS/MAX(PPCM,TINY14)
27371 THECMS = THECMS/BOG
27382 * set flag for "grey/black"
27386 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
27387 IF (MULDEF.EQ.1) THEN
27389 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
27390 & (EK.LE.375.0D-3) ).OR.
27391 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
27392 & (EK.LE. 56.0D-3) ).OR.
27393 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
27394 & (EK.LE. 56.0D-3) ).OR.
27395 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
27396 & (EK.LE.198.0D-3) ).OR.
27397 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
27398 & (EK.LE.198.0D-3) ).OR.
27399 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
27400 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
27401 & (IDBJT.NE.16).AND.
27402 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
27404 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
27405 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
27406 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
27407 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
27408 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
27409 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
27410 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
27411 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
27415 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
27416 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
27419 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
27425 ICHAR = IDXRES(IDX)
27426 AMASS = PHKK(5,IDX)
27433 PTOT = SQRT(PT2+PZ**2)
27434 SINTHE = PT/MAX(PTOT,TINY14)
27435 COSTHE = PZ/MAX(PTOT,TINY14)
27436 IF (COSTHE.GT.ONE) THEN
27438 ELSEIF (COSTHE.LT.-ONE) THEN
27439 THETA = TWOPI/2.0D0
27441 THETA = ACOS(COSTHE)
27444 **sr 15.4.96 new E_t-definition
27448 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
27449 ETA = -LOG(TAN(THETA/TWO))
27461 *===himult=============================================================*
27463 CDECK ID>, DT_HIMULT
27464 SUBROUTINE DT_HIMULT(MODE)
27466 ************************************************************************
27467 * Tables of average energies/multiplicities. *
27468 * This version dated 30.08.2000 is written by S. Roesler *
27469 ************************************************************************
27471 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27474 PARAMETER ( LINP = 5 ,
27478 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27480 PARAMETER (SWMEXP=1.7D0)
27482 CHARACTER*8 ANAMEH(4)
27484 * particle properties (BAMJET index convention)
27486 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27487 & IICH(210),IIBAR(210),K1(210),K2(210)
27488 * temporary storage for one final state particle
27489 LOGICAL LFRAG,LGREY,LBLACK
27490 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
27491 & SINTHE,COSTHE,THETA,THECMS,
27492 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
27493 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
27494 & LFRAG,LGREY,LBLACK
27495 * event flag used for histograms
27496 COMMON /DTNORM/ ICEVT,IEVHKK
27497 * Lorentz-parameters of the current interaction
27498 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27499 & UMO,PPCM,EPROJ,PPROJ
27501 PARAMETER (NOPART=210)
27502 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
27503 & AVPT(4,NOPART),IAVPT(4,NOPART)
27504 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
27508 *------------------------------------------------------------------
27523 *------------------------------------------------------------------
27524 * filling of histogram with event-record
27526 IF (PE.LT.0.0D0) THEN
27527 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
27530 IF (.NOT.LFRAG) THEN
27532 IF (LGREY) IVEL = 3
27533 IF (LBLACK) IVEL = 4
27534 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
27535 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
27536 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
27537 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
27538 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
27539 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
27540 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
27541 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
27542 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
27543 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
27544 IF (IDBJT.LT.116) THEN
27545 * total energy, multiplicity
27546 AVE(1,30) = AVE(1,30) +PE
27547 AVE(IVEL,30) = AVE(IVEL,30)+PE
27548 AVPT(1,30) = AVPT(1,30) +PT
27549 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
27550 IAVPT(1,30) = IAVPT(1,30) +1
27551 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
27552 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
27553 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
27554 AVMULT(1,30) = AVMULT(1,30) +ONE
27555 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
27556 * charged energy, multiplicity
27557 IF (ICHAR.LT.0) THEN
27558 AVE(1,26) = AVE(1,26) +PE
27559 AVE(IVEL,26) = AVE(IVEL,26)+PE
27560 AVPT(1,26) = AVPT(1,26) +PT
27561 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
27562 IAVPT(1,26) = IAVPT(1,26) +1
27563 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
27564 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
27565 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
27566 AVMULT(1,26) = AVMULT(1,26) +ONE
27567 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
27569 IF (ICHAR.NE.0) THEN
27570 AVE(1,27) = AVE(1,27) +PE
27571 AVE(IVEL,27) = AVE(IVEL,27)+PE
27572 AVPT(1,27) = AVPT(1,27) +PT
27573 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
27574 IAVPT(1,27) = IAVPT(1,27) +1
27575 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
27576 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
27577 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
27578 AVMULT(1,27) = AVMULT(1,27) +ONE
27579 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
27586 *------------------------------------------------------------------
27590 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
27591 & 29X,'---------------------',/)
27592 PRINT*,' MULDEF = ',MULDEF
27593 IF (MULDEF.EQ.1) THEN
27594 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
27598 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
27599 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
27600 & ,F4.2,' black: beta < ',F4.2,/)
27602 WRITE(LOUT,3003) SWMEXP
27603 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
27604 & 13X,'| total fast',
27605 C & ' grey black K f(',F3.1,')',/,1X,
27606 & ' grey black <pt> f(',F3.1,')',/,1X,
27607 & '------------+--------------',
27608 & '-------------------------------------------------')
27611 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
27612 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
27613 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
27614 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
27617 WRITE(LOUT,3004) ANAME(I),I,
27618 & AVMULT(1,I),AVMULT(2,I),
27619 & AVMULT(3,I),AVMULT(4,I),
27620 C & AVE(1,I),AVSWM(1,I)
27621 & AVPT(1,I),AVSWM(1,I)
27622 ELSEIF (I.LE.119) THEN
27623 WRITE(LOUT,3004) ANAMEH(I-115),I,
27624 & AVMULT(1,I),AVMULT(2,I),
27625 & AVMULT(3,I),AVMULT(4,I),
27626 C & AVE(1,I),AVSWM(1,I)
27627 & AVPT(1,I),AVSWM(1,I)
27629 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
27632 C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
27633 C & AVMULT(3,27)+AVMULT(4,27)
27639 *===histat=============================================================*
27641 CDECK ID>, DT_HISTAT
27642 SUBROUTINE DT_HISTAT(IDX,MODE)
27644 ************************************************************************
27645 * This version dated 26.02.96 is written by S. Roesler *
27646 ************************************************************************
27648 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27651 PARAMETER ( LINP = 5 ,
27655 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27656 PARAMETER (NDIM=199)
27660 PARAMETER (NMXHKK=200000)
27662 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27663 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27664 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27665 * extended event history
27666 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27667 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27669 * particle properties (BAMJET index convention)
27671 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27672 & IICH(210),IIBAR(210),K1(210),K2(210)
27674 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27676 * Glauber formalism: cross sections
27677 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
27678 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
27679 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
27680 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
27681 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
27682 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
27683 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
27684 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
27685 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
27686 & BSLOPE,NEBINI,NQBINI
27687 * emulsion treatment
27688 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27690 * properties of interacting particles
27691 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
27692 * rejection counter
27693 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27694 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27695 & IREXCI(3),IRDIFF(2),IRINC
27696 * statistics: residual nuclei
27697 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
27698 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
27699 & NINCST(2,4),NINCEV(2),
27700 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
27701 & NRESPB(2),NRESCH(2),NRESEV(4),
27702 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
27704 * parameter for intranuclear cascade
27706 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
27713 * temporary storage for one final state particle
27714 LOGICAL LFRAG,LGREY,LBLACK
27715 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
27716 & SINTHE,COSTHE,THETA,THECMS,
27717 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
27718 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
27719 & LFRAG,LGREY,LBLACK
27720 * event flag used for histograms
27721 COMMON /DTNORM/ ICEVT,IEVHKK
27722 * statistics: double-Pomeron exchange
27723 COMMON /DTFLG2/ INTFLG,IPOPO
27725 DIMENSION EMUSAM(NCOMPX)
27727 CHARACTER*13 CMSG(3)
27728 DATA CMSG /'not requested','not requested','not requested'/
27730 GOTO (1,2,3,4,5) MODE
27732 *------------------------------------------------------------------
27735 * emulsion treatment
27736 IF (NCOMPO.GT.0) THEN
27741 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
27762 IF (J.LE.2) NINCHR(I,J) = 0
27763 IF (J.LE.3) NINCCO(I,J) = 0
27764 IF (J.LE.4) NINCST(I,J) = 0
27773 **dble Po statistics.
27777 *------------------------------------------------------------------
27778 * filling of histogram with event-record
27780 IF (IST.EQ.-1) THEN
27781 IF (.NOT.LFRAG) THEN
27782 IF (IDPDG.EQ.2212) THEN
27783 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
27784 ELSEIF (IDPDG.EQ.2112) THEN
27785 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
27786 ELSEIF (IDPDG.EQ.22) THEN
27787 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
27788 ELSEIF (IDPDG.EQ.80000) THEN
27789 IF (IDBJT.EQ.116) THEN
27790 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
27791 ELSEIF (IDBJT.EQ.117) THEN
27792 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
27793 ELSEIF (IDBJT.EQ.118) THEN
27794 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
27795 ELSEIF (IDBJT.EQ.119) THEN
27796 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
27800 * heavy fragments (here: fission products only)
27801 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
27802 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
27803 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
27805 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
27806 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
27810 *------------------------------------------------------------------
27814 **dble Po statistics.
27815 C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
27816 C & '# evts. / # dble-Po. evts / s_in / s_popo :',
27817 C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
27819 * emulsion treatment
27820 IF (NCOMPO.GT.0) THEN
27822 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
27823 & 22X,'----------------------------',/,/,19X,
27824 & 'mass charge fraction',/,39X,
27825 & 'input treated',/)
27827 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
27828 & EMUSAM(I)/DBLE(ICEVT)
27829 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
27833 * i.n.c. statistics: output
27834 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
27835 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
27836 & 22X,'---------------------------------',/,/,1X,
27837 & 'no. of events for normalization: (accepted final events,',
27838 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
27839 & /,1X,'no. of rejected events due to intranuclear',
27840 & ' cascade',15X,I6,/)
27841 ICEV = MAX(ICEVT,1)
27843 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
27845 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
27846 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
27847 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
27848 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
27849 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
27850 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
27851 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
27852 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
27853 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
27854 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
27855 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
27856 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
27857 & /,1X,'maximum no. of generations treated (maximum allowed:'
27858 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
27859 & ' interactions in proj./ target (mean per evt1)',
27860 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
27861 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
27862 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
27863 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
27864 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
27865 & IREXCI(1)+IREXCI(2)+IREXCI(3)
27866 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
27867 & 'evaporation',/,22X,'-----------------------------',
27868 & '------------',/,/,1X,'no. of events for normal.: ',
27869 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
27870 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
27871 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
27874 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
27875 ICEV = MAX(NRESEV(2),1)
27877 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
27878 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
27879 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
27880 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
27881 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
27882 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
27883 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
27884 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
27885 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
27886 & 'proj. / target',/,/,8X,'total number of particles',15X,
27887 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
27888 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
27889 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
27890 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
27891 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
27893 * evaporation / fission / fragmentation statistics: output
27894 ICEV = MAX(NRESEV(2),1)
27895 ICEV1 = MAX(NRESEV(4),1)
27897 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
27899 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
27901 IF (IFISS.EQ.1) CMSG(1) = 'requested '
27902 IF (LFRMBK) CMSG(2) = 'requested '
27903 IF (LDEEXG) CMSG(3) = 'requested '
27906 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
27907 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
27908 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
27909 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
27910 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
27911 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
27912 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
27913 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
27914 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
27915 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
27916 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
27917 & 'deexcitation:',2X,A13,/,/,
27918 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
27919 & 'proj. / target',/,/,8X,'total number of evap. particles',
27920 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
27921 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
27922 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
27923 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
27924 & 'heavy fragments',25X,2F9.3,/)
27925 IF (IFISS.EQ.1) THEN
27926 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
27927 & NEVAFI(2,1),NEVAFI(2,2),
27928 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
27929 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
27930 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
27931 & 12X,'out of which fission occured',8X,2I9,/,
27932 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
27934 C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
27936 C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
27937 C & ' proj. / target',/)
27939 C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
27940 C WRITE(LOUT,3009) I,
27941 C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
27942 C3009 FORMAT(38X,I3,3X,2E12.3)
27946 C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
27947 C & ' proj. / target',/)
27949 C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
27950 C WRITE(LOUT,3011) I,
27951 C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
27952 C3011 FORMAT(38X,I3,3X,2E12.3)
27959 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
27960 & 'Evaporation: not requested',/)
27964 *------------------------------------------------------------------
27965 * filling of histogram with event-record
27967 * emulsion treatment
27968 IF (NCOMPO.GT.0) THEN
27970 IF (IT.EQ.IEMUMA(I)) THEN
27971 EMUSAM(I) = EMUSAM(I)+ONE
27975 NINCGE = NINCGE+MAXGEN
27977 **dble Po statistics.
27978 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
27981 *------------------------------------------------------------------
27982 * filling of histogram with event-record
27984 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
27985 IB = IIBAR(IDBAM(IDX))
27986 IC = IICH(IDBAM(IDX))
27988 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
27989 NINCST(J,1) = NINCST(J,1)+1
27990 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
27991 NINCST(J,2) = NINCST(J,2)+1
27992 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
27993 NINCST(J,3) = NINCST(J,3)+1
27994 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
27995 NINCST(J,4) = NINCST(J,4)+1
27997 ELSEIF (ISTHKK(IDX).EQ.17) THEN
27998 NINCWO(1) = NINCWO(1)+1
27999 ELSEIF (ISTHKK(IDX).EQ.18) THEN
28000 NINCWO(2) = NINCWO(2)+1
28001 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
28005 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
28006 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
28008 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
28014 *===newhgr=============================================================*
28016 CDECK ID>, DT_NEWHGR
28017 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
28019 ************************************************************************
28021 * Histogram initialization. *
28023 * input: XLIM1/XLIM2 lower/upper edge of histogram-window *
28025 * IBIN > 0 number of bins in equidistant lin. binning *
28026 * = -1 reset histograms *
28027 * < -1 |IBIN| number of bins in equidistant log. *
28028 * binning or log. binning in user def. struc. *
28029 * XLIMB(*) user defined bin structure *
28031 * The bin structure is sensitive to *
28032 * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
28033 * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
28034 * XLIMB, IBIN if XLIM3 < 0 *
28037 * output: IREFN histogram index *
28038 * (= -1 for inconsistent histogr. request) *
28040 * This subroutine is based on a original version by R. Engel. *
28041 * This version dated 22.4.95 is written by S. Roesler. *
28042 ************************************************************************
28044 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28047 PARAMETER ( LINP = 5 ,
28053 PARAMETER (ZERO = 0.0D0,
28060 PARAMETER (NHIS=150, NDIM=250)
28062 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28063 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28064 * auxiliary common for histograms
28065 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
28067 DATA LSTART /.TRUE./
28069 * reset histogram counter
28070 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
28072 IF (IBIN.EQ.-1) RETURN
28077 * check for maximum number of allowed histograms
28078 IF (IHIS.GT.NHIS) THEN
28079 WRITE(LOUT,1003) IHIS,NHIS,IHIS
28080 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
28081 & I4,') exceeds array size (',I4,')',/,21X,
28082 & 'histogram',I3,' skipped!')
28087 IBINS(IHIS) = ABS(IBIN)
28088 * check requested number of bins
28089 IF (IBINS(IHIS).GE.NDIM) THEN
28090 WRITE(LOUT,1000) IBIN,NDIM,NDIM
28091 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
28092 & I3,') exceeds array size (',I3,')',/,21X,
28093 & 'and will be reset to ',I3)
28096 IF (IBINS(IHIS).EQ.0) THEN
28097 WRITE(LOUT,1001) IBIN,IHIS
28098 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
28099 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
28103 * initialize arrays
28106 HIST(K,IHIS,I) = ZERO
28107 HIST(K+3,IHIS,I) = ZERO
28108 TMPHIS(K,IHIS,I) = ZERO
28110 HIST(7,IHIS,I) = ZERO
28112 DENTRY(1,IHIS)= ZERO
28113 DENTRY(2,IHIS)= ZERO
28115 UNDERF(IHIS) = ZERO
28116 TMPUFL(IHIS) = ZERO
28117 TMPOFL(IHIS) = ZERO
28119 * bin str. sensitive to lower edge, bin size, and numb. of bins
28120 IF (XLIM3.GT.ZERO) THEN
28121 DO 3 K=1,IBINS(IHIS)+1
28122 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
28125 * bin str. sensitive to lower/upper edge and numb. of bins
28126 ELSEIF (XLIM3.EQ.ZERO) THEN
28128 IF (IBIN.GT.0) THEN
28131 IF (XLIM2.LE.XLIM1) THEN
28132 WRITE(LOUT,1002) XLIM1,XLIM2
28133 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
28134 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
28138 ELSEIF (IBIN.LT.-1) THEN
28139 * logarithmic binning
28140 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
28141 WRITE(LOUT,1004) XLIM1,XLIM2
28142 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
28143 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
28146 IF (XLIM2.LE.XLIM1) THEN
28147 WRITE(LOUT,1005) XLIM1,XLIM2
28148 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
28149 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
28152 XLOW = LOG10(XLIM1)
28156 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
28157 DO 4 K=1,IBINS(IHIS)+1
28158 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
28161 * user defined bin structure
28162 DO 5 K=1,IBINS(IHIS)+1
28163 IF (IBIN.GT.0) THEN
28164 HIST(1,IHIS,K) = XLIMB(K)
28166 ELSEIF (IBIN.LT.-1) THEN
28167 HIST(1,IHIS,K) = LOG10(XLIMB(K))
28173 * histogram accepted
28183 *===filhgr=============================================================*
28185 CDECK ID>, DT_FILHGR
28186 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
28188 ************************************************************************
28190 * Scoring for histogram IHIS. *
28192 * This subroutine is based on a original version by R. Engel. *
28193 * This version dated 23.4.95 is written by S. Roesler. *
28194 ************************************************************************
28196 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28199 PARAMETER ( LINP = 5 ,
28203 PARAMETER (ZERO = 0.0D0,
28209 PARAMETER (NHIS=150, NDIM=250)
28211 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28212 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28213 * auxiliary common for histograms
28214 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
28221 * dump content of temorary arrays into histograms
28222 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
28223 CALL DT_EVTHIS(IDUM)
28227 * check histogram index
28228 IF (IHIS.EQ.-1) RETURN
28229 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
28230 C WRITE(LOUT,1000) IHIS,IHISL
28231 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
28232 & ' out of range (1..',I3,')')
28236 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
28237 * bin structure not explicitly given
28238 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
28239 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
28240 IF (X.LT.HIST(1,IHIS,1)) THEN
28243 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
28246 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
28247 * user defined bin structure
28248 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
28249 IF (X.LT.HIST(1,IHIS,1)) THEN
28251 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
28254 * binary sort algorithm
28256 KMAX = IBINS(IHIS)+1
28258 IF ((KMAX-KMIN).EQ.1) GOTO 2
28260 IF (X.LE.HIST(1,IHIS,KK)) THEN
28272 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
28278 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
28279 ELSEIF (I1.LE.IBINS(IHIS)) THEN
28280 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
28281 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
28282 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
28284 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
28286 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
28288 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
28294 *===evthis=============================================================*
28296 CDECK ID>, DT_EVTHIS
28297 SUBROUTINE DT_EVTHIS(NEVT)
28299 ************************************************************************
28300 * Dump content of temorary histograms into /DTHIS1/. This subroutine *
28301 * is called after each event and for the last event before any call *
28303 * NEVT number of events dumped, this is only needed to *
28304 * get the normalization after the last event *
28305 * This version dated 23.4.95 is written by S. Roesler. *
28306 ************************************************************************
28308 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28311 PARAMETER ( LINP = 5 ,
28317 PARAMETER (ZERO = 0.0D0,
28323 PARAMETER (NHIS=150, NDIM=250)
28325 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28326 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28327 * auxiliary common for histograms
28328 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
28338 IF (TMPHIS(1,I,J).GT.ZERO) THEN
28340 HIST(2,I,J) = HIST(2,I,J)+ONE
28341 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
28342 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
28343 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
28344 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
28345 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
28346 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
28347 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
28348 TMPHIS(1,I,J) = ZERO
28349 TMPHIS(2,I,J) = ZERO
28350 TMPHIS(3,I,J) = ZERO
28354 IF (TMPUFL(I).GT.ZERO) THEN
28355 UNDERF(I) = UNDERF(I)+ONE
28357 ELSEIF (TMPOFL(I).GT.ZERO) THEN
28358 OVERF(I) = OVERF(I)+ONE
28362 DENTRY(1,I) = DENTRY(1,I)+ONE
28369 *===outhgr=============================================================*
28371 CDECK ID>, DT_OUTHGR
28372 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
28373 & ILOGY,INORM,NMODE)
28375 ************************************************************************
28377 * Plot histogram(s) to standard output unit *
28379 * I1..6 indices of histograms to be plotted *
28380 * CHEAD,IHEAD header string,integer *
28381 * NEVTS number of events *
28382 * FAC scaling factor *
28383 * ILOGY = 1 logarithmic y-axis *
28384 * INORM normalization *
28385 * = 0 no further normalization (FAC is obsolete) *
28386 * = 1 per event and bin width *
28387 * = 2 per entry and bin width *
28388 * = 3 per bin entry *
28389 * = 4 per event and "bin width" x1^2...x2^2 *
28390 * = 5 per event and "log. bin width" ln x1..ln x2 *
28392 * MODE = 0 no output but normalization applied *
28393 * = 1 all valid histograms separately (small frame) *
28394 * all valid histograms separately (small frame) *
28395 * = -1 and tables as histograms *
28396 * = 2 all valid histograms (one plot, wide frame) *
28397 * all valid histograms (one plot, wide frame) *
28398 * = -2 and tables as histograms *
28401 * Note: All histograms to be plotted with one call to this *
28402 * subroutine and |MODE|=2 must have the same bin structure! *
28403 * There is no test included ensuring this fact. *
28405 * This version dated 23.4.95 is written by S. Roesler. *
28406 ************************************************************************
28408 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28411 PARAMETER ( LINP = 5 ,
28417 PARAMETER (ZERO = 0.0D0,
28429 PARAMETER (NHIS=150, NDIM=250)
28431 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28432 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28434 PARAMETER (NDIM2 = 2*NDIM)
28435 DIMENSION XX(NDIM2),YY(NDIM2)
28437 PARAMETER (NHISTO = 6)
28438 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
28441 CHARACTER*43 CNORM(0:8)
28442 DATA CNORM /'no further normalization ',
28443 & 'per event and bin width ',
28444 & 'per entry1 and bin width ',
28445 & 'per bin entry ',
28446 & 'per event and "bin width" x1^2...x2^2 ',
28447 & 'per event and "log. bin width" ln x1..ln x2',
28449 & 'per bin entry1 ',
28450 & 'per entry2 and bin width '/
28461 * initialization if "wide frame" is requested
28462 IF (ABS(MODE).EQ.2) THEN
28472 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
28474 * check histogram indices
28477 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
28478 IF (ISWI(IDX1(I)).NE.0) THEN
28479 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
28481 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
28482 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
28483 & ' histogram ',I3,/,21X,'underflows:',F10.0,
28484 & ' overflows: ',F10.0)
28494 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
28498 * check normalization request
28499 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
28500 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
28501 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
28502 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
28503 WRITE(LOUT,1002) NEVTS,INORM,FAC
28504 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
28505 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
28510 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
28512 * apply normalization
28517 IF (ISWI(I).EQ.1) THEN
28518 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
28519 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
28520 & ' to',2X,E10.4,',',2X,I3,' bins')
28521 ELSEIF (ISWI(I).EQ.2) THEN
28522 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
28524 1007 FORMAT(1X,'user defined bin structure')
28525 ELSEIF (ISWI(I).EQ.3) THEN
28527 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
28528 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
28529 & ' to',2X,E10.4,',',2X,I3,' bins')
28530 ELSEIF (ISWI(I).EQ.4) THEN
28532 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
28535 WRITE(LOUT,1008) ISWI(I)
28536 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
28538 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
28539 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
28540 & ' overfl.:',F8.0)
28541 WRITE(LOUT,1009) CNORM(INORM)
28542 1009 FORMAT(1X,'normalization: ',A,/)
28545 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
28548 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
28549 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
28550 1006 FORMAT(1X,5E11.3)
28553 XX(II-1) = HIST(1,I,K)
28554 XX(II) = HIST(1,I,K+1)
28559 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
28560 & XX1(K,N) = LOG10(XMEAN)
28565 IF (ABS(MODE).EQ.1) THEN
28567 WRITE(LOUT,'(/,1X,A)') 'Preview:'
28568 IF(ILOGY.EQ.1) THEN
28569 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
28571 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
28578 IF (ABS(MODE).EQ.2) THEN
28579 WRITE(LOUT,'(/,1X,A)') 'Preview:'
28580 NSIZE = NDIM*NHISTO
28581 DXLOW = HIST(1,IDX(1),1)
28582 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
28587 IF (YY1(J,I).LT.YLOW) THEN
28588 IF (ILOGY.EQ.1) THEN
28589 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
28594 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
28597 DY = (YHI-YLOW)/DBLE(NDIM)
28598 IF (DY.LE.ZERO) THEN
28599 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
28600 & 'OUTHGR: warning! zero bin width for histograms ',
28601 & IDX,': ',YLOW,YHI
28604 IF (ILOGY.EQ.1) THEN
28606 DY = (LOG10(YHI)-YLOW)/100.0D0
28609 IF (YY1(J,I).LE.ZERO) THEN
28612 YY1(J,I) = LOG10(YY1(J,I))
28617 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
28623 *===getbin=============================================================*
28625 CDECK ID>, DT_GETBIN
28626 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
28627 & XMEAN,YMEAN,YERR)
28629 ************************************************************************
28630 * This version dated 23.4.95 is written by S. Roesler. *
28631 ************************************************************************
28633 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28636 PARAMETER ( LINP = 5 ,
28640 PARAMETER (ZERO = 0.0D0,
28642 & TINY35 = 1.0D-35)
28646 PARAMETER (NHIS=150, NDIM=250)
28648 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28649 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28651 XLOW = HIST(1,IHIS,IBIN)
28652 XHI = HIST(1,IHIS,IBIN+1)
28653 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
28657 IF (NORM.EQ.2) THEN
28659 NEVT = INT(DENTRY(1,IHIS))
28660 ELSEIF (NORM.EQ.3) THEN
28662 NEVT = INT(HIST(2,IHIS,IBIN))
28663 ELSEIF (NORM.EQ.4) THEN
28664 DX = XHI**2-XLOW**2
28666 ELSEIF (NORM.EQ.5) THEN
28667 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
28669 ELSEIF (NORM.EQ.6) THEN
28672 ELSEIF (NORM.EQ.7) THEN
28674 NEVT = INT(HIST(7,IHIS,IBIN))
28675 ELSEIF (NORM.EQ.8) THEN
28677 NEVT = INT(DENTRY(2,IHIS))
28682 IF (ABS(DX).LT.TINY35) DX = ONE
28684 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
28685 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
28686 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
28687 YSUM = HIST(5,IHIS,IBIN)
28688 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
28689 C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
28690 XMEAN = HIST(3,IHIS,IBIN)/YSUM
28691 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
28696 *===joihis=============================================================*
28698 CDECK ID>, DT_JOIHIS
28699 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
28701 ************************************************************************
28703 * Operation on histograms. *
28705 * input: IH1,IH2 histogram indices to be joined *
28706 * COPER character defining the requested operation, *
28707 * i.e. '+', '-', '*', '/' *
28708 * FAC1,FAC2 factors for joining, i.e. *
28709 * FAC1*histo1 COPER FAC2*histo2 *
28711 * This version dated 23.4.95 is written by S. Roesler. *
28712 ************************************************************************
28714 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28717 PARAMETER ( LINP = 5 ,
28723 PARAMETER (ZERO = 0.0D0,
28732 PARAMETER (NHIS=150, NDIM=250)
28734 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28735 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28737 PARAMETER (NDIM2 = 2*NDIM)
28738 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
28740 CHARACTER*43 CNORM(0:6)
28741 DATA CNORM /'no further normalization ',
28742 & 'per event and bin width ',
28743 & 'per entry and bin width ',
28744 & 'per bin entry ',
28745 & 'per event and "bin width" x1^2...x2^2 ',
28746 & 'per event and "log. bin width" ln x1..ln x2',
28749 * check histogram indices
28750 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
28751 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
28752 WRITE(LOUT,1000) IH1,IH2,IHISL
28753 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
28754 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
28758 * check bin structure of histograms to be joined
28759 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
28760 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
28761 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
28762 & ' and ',I3,' failed',/,21X,
28763 & 'due to different numbers of bins (',I3,',',I3,')')
28766 DO 1 K=1,IBINS(IH1)+1
28767 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
28768 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
28769 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
28770 & ' and ',I3,' failed at bin edge ',I3,/,21X,
28771 & 'X1,X2 = ',2E11.4)
28776 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
28777 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
28778 & 'operation ',A,/,11X,'and factors ',2E11.4)
28779 WRITE(LOUT,1004) CNORM(NORM)
28780 1004 FORMAT(1X,'normalization: ',A,/)
28782 DO 2 K=1,IBINS(IH1)
28783 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
28784 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
28787 XMEAN = OHALF*(XMEAN1+XMEAN2)
28788 IF (COPER.EQ.'+') THEN
28789 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
28790 ELSEIF (COPER.EQ.'*') THEN
28791 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
28792 ELSEIF (COPER.EQ.'/') THEN
28793 IF (YMEAN2.EQ.ZERO) THEN
28796 IF (FAC2.EQ.ZERO) FAC2 = ONE
28797 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
28802 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
28803 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
28804 1006 FORMAT(1X,5E11.3)
28807 XX(II-1) = HIST(1,IH1,K)
28808 XX(II) = HIST(1,IH1,K+1)
28813 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
28818 IF (ABS(MODE).EQ.1) THEN
28819 IBIN2 = 2*IBINS(IH1)
28820 WRITE(LOUT,'(/,1X,A)') 'Preview:'
28821 IF(ILOGY.EQ.1) THEN
28822 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
28824 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
28829 IF (ABS(MODE).EQ.2) THEN
28830 WRITE(LOUT,'(/,1X,A)') 'Preview:'
28832 DXLOW = HIST(1,IH1,1)
28833 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
28837 IF (YY1(I).LT.YLOW) THEN
28838 IF (ILOGY.EQ.1) THEN
28839 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
28844 IF (YY1(I).GT.YHI) YHI = YY1(I)
28846 DY = (YHI-YLOW)/DBLE(NDIM)
28847 IF (DY.LE.ZERO) THEN
28848 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
28849 & 'JOIHIS: warning! zero bin width for histograms ',
28850 & IH1,IH2,': ',YLOW,YHI
28853 IF (ILOGY.EQ.1) THEN
28855 DY = (LOG10(YHI)-YLOW)/100.0D0
28857 IF (YY1(I).LE.ZERO) THEN
28860 YY1(I) = LOG10(YY1(I))
28864 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
28870 WRITE(LOUT,1005) COPER
28871 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
28877 *===qgraph=============================================================*
28879 CDECK ID>, DT_XGRAPH
28880 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
28881 C***********************************************************************
28883 C calculate quasi graphic picture with 25 lines and 79 columns
28884 C ranges will be chosen automatically
28886 C input N dimension of input fields
28887 C IARG number of curves (fields) to plot
28892 C This subroutine is written by R. Engel.
28893 C***********************************************************************
28894 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28897 PARAMETER ( LINP = 5 ,
28902 DIMENSION X(N),Y1(N),Y2(N)
28903 PARAMETER (EPS=1.D-30)
28904 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
28906 CHARACTER COL(0:149,0:49)
28908 DATA SYMB /'0','e','z','#','x'/
28912 C*** automatic range fitting
28917 XMAX=MAX(X(I),XMAX)
28918 XMIN=MIN(X(I),XMIN)
28920 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
28923 DO 1100 K=0,IZEIL-1
28925 IF (ITEST.EQ.IYRAST) THEN
28926 DO 1010 L=1,ISPALT-1
28931 DO 1020 L=0,ISPALT-1,IXRAST
28935 DO 1030 L=1,ISPALT-1
28938 DO 1040 L=0,ISPALT-1,IXRAST
28950 YMAX=MAX(Y1(I),YMAX)
28951 YMIN=MIN(Y1(I),YMIN)
28955 YMAX=MAX(Y2(I),YMAX)
28956 YMIN=MIN(Y2(I),YMIN)
28959 YMAX=(YMAX-YMIN)/40.0D0+YMAX
28960 YMIN=YMIN-(YMAX-YMIN)/40.0D0
28961 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
28962 IF(YZOOM.LT.EPS) THEN
28963 WRITE(LOUT,'(1X,A)')
28964 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
28973 L=NINT((X(K)-XMIN)/XZOOM)
28974 I=NINT((YMAX-Y1(K))/YZOOM)
28975 IF(ILAST.GE.0) THEN
28978 DO 55 II=0,LD,SIGN(1,LD)
28979 DO 66 KK=0,ID,SIGN(1,ID)
28980 COL(II+LLAST,KK+ILAST)=SYMB(1)
28995 L=NINT((X(K)-XMIN)/XZOOM)
28996 I=NINT((YMAX-Y2(K))/YZOOM)
29003 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29005 C*** write range of X
29007 XZOOM = (XMAX-XMIN)/DBLE(7)
29008 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
29010 DO 1300 K=0,IZEIL-1
29011 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
29012 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
29013 110 FORMAT(1X,1PE9.2,70A1)
29016 C*** write range of X
29018 XZOOM = (XMAX-XMIN)/DBLE(7)
29019 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
29020 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29021 120 FORMAT(6X,7(1PE10.3))
29024 *===qglogy=============================================================*
29026 CDECK ID>, DT_XGLOGY
29027 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
29028 C***********************************************************************
29030 C calculate quasi graphic picture with 25 lines and 79 columns
29031 C logarithmic y axis
29032 C ranges will be chosen automatically
29034 C input N dimension of input fields
29035 C IARG number of curves (fields) to plot
29040 C This subroutine is written by R. Engel.
29041 C***********************************************************************
29043 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29046 PARAMETER ( LINP = 5 ,
29050 DIMENSION X(N),Y1(N),Y2(N)
29051 PARAMETER (EPS=1.D-30)
29052 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
29054 CHARACTER COL(0:149,0:49)
29055 PARAMETER (DEPS = 1.D-10)
29057 DATA SYMB /'0','e','z','#','x'/
29061 C*** automatic range fitting
29066 XMAX=MAX(X(I),XMAX)
29067 XMIN=MIN(X(I),XMIN)
29069 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
29072 DO 1100 K=0,IZEIL-1
29074 IF (ITEST.EQ.IYRAST) THEN
29075 DO 1010 L=1,ISPALT-1
29080 DO 1020 L=0,ISPALT-1,IXRAST
29084 DO 1030 L=1,ISPALT-1
29087 DO 1040 L=0,ISPALT-1,IXRAST
29097 YMIN=MAX(Y1(1),EPS)
29099 YMAX =MAX(Y1(I),YMAX)
29100 IF(Y1(I).GT.EPS) THEN
29101 IF(YMIN.EQ.EPS) THEN
29104 YMIN = MIN(Y1(I),YMIN)
29110 YMAX=MAX(Y2(I),YMAX)
29111 IF(Y2(I).GT.EPS) THEN
29112 IF(YMIN.EQ.EPS) THEN
29115 YMIN = MIN(Y2(I),YMIN)
29122 Y1(I) = MAX(Y1(I),YMIN)
29126 Y2(I) = MAX(Y2(I),YMIN)
29130 IF(YMAX.LE.YMIN) THEN
29131 WRITE(LOUT,'(/1X,A,2E12.3,/)')
29132 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
29133 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
29137 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
29138 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
29139 YZOOM=(YMA-YMI)/DBLE(IZEIL)
29140 IF(YZOOM.LT.EPS) THEN
29141 WRITE(LOUT,'(1X,A)')
29142 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
29151 L=NINT((X(K)-XMIN)/XZOOM)
29152 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
29153 IF(ILAST.GE.0) THEN
29156 DO 55 II=0,LD,SIGN(1,LD)
29157 DO 66 KK=0,ID,SIGN(1,ID)
29158 COL(II+LLAST,KK+ILAST)=SYMB(1)
29173 L=NINT((X(K)-XMIN)/XZOOM)
29174 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
29181 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
29182 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29184 C*** write range of X
29186 XZOOM1 = (XMAX-XMIN)/DBLE(7)
29187 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
29189 DO 1300 K=0,IZEIL-1
29190 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
29191 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
29192 110 FORMAT(1X,1PE9.2,70A1)
29195 C*** write range of X
29197 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
29198 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29199 120 FORMAT(6X,7(1PE10.3))
29203 *===plot===============================================================*
29205 CDECK ID>, DT_SRPLOT
29206 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
29208 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29211 PARAMETER ( LINP = 5 ,
29217 * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
29218 * This is a subroutine of fluka to plot Y across the page
29219 * as a function of X down the page. Up to 37 curves can be
29220 * plotted in the same picture with different plotting characters.
29221 * Output of first 10 overprinted characters addad by FB 88
29222 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
29225 * X = array containing the values of X
29226 * Y = array containing the values of Y
29227 * N = number of values in X and in Y
29228 * can exceed the fixed number of lines
29229 * M = number of different curves X,Y are containing
29230 * MM = number of points in each curve i.e. N=M*MM
29231 * XO = smallest value of X to be plotted
29232 * DX = increment of X between subsequent lines
29233 * YO = smallest value of Y to be plotted
29234 * DY = increment of Y between subsequent character spaces
29236 * other variables used inside:
29237 * XX = numbers along the X-coordinate axis
29238 * YY = numbers along the Y-coordinate axis
29239 * LL = ten lines temporary storage for the plot
29240 * L = character set used to plot different curves
29241 * LOV = memorizes overprinted symbols
29242 * the first 10 overprinted symbols are printed on
29243 * the end of the line to avoid ambiguities
29244 * (added by FB as considered quite helpful)
29246 *********************************************************************
29248 DIMENSION XX(61),YY(61),LL(101,10)
29249 DIMENSION X(N),Y(N),L(40),LOV(40,10)
29251 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
29252 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
29253 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
29254 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
29263 20 YY(I)=YO+10.0D0*AI*DY
29264 WRITE(LOUT, 500) (YY(I),I=1,11)
29286 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
29287 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
29289 * changed Sept.88 by FB to avoid INTEGER OVERFLOW
29290 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
29291 + . AIY .LT. 102.D0) THEN
29294 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
29296 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
29307 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
29308 & (LOV(J,I),J=1,10)
29314 WRITE(LOUT, 500) (YY(I),I=1,11)
29317 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
29318 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
29319 520 FORMAT(20X,10('1---------'),'1')
29322 *===defset=============================================================*
29324 CDECK ID>, DT_DEFSET
29325 BLOCK DATA DT_DEFSET
29327 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29330 * flags for input different options
29331 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
29332 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
29333 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
29335 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29337 * emulsion treatment
29338 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29342 DATA IFRAG / 2, 1 /
29346 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
29347 DATA LEMCCK / .FALSE. /
29348 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
29349 & .TRUE.,.TRUE.,.TRUE./
29350 DATA LSEADI / .TRUE. /
29351 DATA LEVAPO / .TRUE. /
29353 * Introduced by Chiara -> Forcing CMS-system
29354 * DATA IFRAME / 2 /
29358 DATA EMUFRA / NCOMPX*0.0D0 /
29359 DATA IEMUMA / NCOMPX*1 /
29360 DATA IEMUCH / NCOMPX*1 /
29367 *===hadprp=============================================================*
29369 CDECK ID>, DT_HADPRP
29370 BLOCK DATA DT_HADPRP
29372 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29375 * auxiliary common for reggeon exchange (DTUNUC 1.x)
29376 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
29377 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
29378 & IQTCHR(-6:6),MQUARK(3,39)
29379 * hadron index conversion (BAMJET <--> PDG)
29380 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
29381 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
29383 * names of hadrons used in input-cards
29385 COMMON /DTPAIN/ BTYPE(30)
29388 *----------------------------------------------------------------------*
29390 * Quark content of particles: *
29391 * index quark el. charge bar. charge isospin isospin3 *
29392 * 1 = u 2/3 1/3 1/2 1/2 *
29393 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
29394 * 2 = d -1/3 1/3 1/2 -1/2 *
29395 * -2 = dbar 1/3 -1/3 1/2 1/2 *
29396 * 3 = s -1/3 1/3 0 0 *
29397 * -3 = sbar 1/3 -1/3 0 0 *
29398 * 4 = c 2/3 1/3 0 0 *
29399 * -4 = cbar -2/3 -1/3 0 0 *
29400 * 5 = b -1/3 1/3 0 0 *
29401 * -5 = bbar 1/3 -1/3 0 0 *
29402 * 6 = t 2/3 1/3 0 0 *
29403 * -6 = tbar -2/3 -1/3 0 0 *
29405 * Mquark = particle quark composition (Paprop numbering) *
29406 * Iqechr = electric charge ( in 1/3 unit ) *
29407 * Iqbchr = baryonic charge ( in 1/3 unit ) *
29408 * Iqichr = isospin ( in 1/2 unit ), z component *
29409 * Iqschr = strangeness *
29411 * Iquchr = beauty *
29412 * Iqtchr = ...... *
29414 *----------------------------------------------------------------------*
29415 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
29416 DATA IQBCHR / 6*-1, 0, 6*1 /
29417 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
29418 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
29419 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
29420 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
29421 DATA IQTCHR / -1, 11*0, 1 /
29423 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29424 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
29425 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
29426 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
29427 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
29428 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29429 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
29430 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
29433 * (renamed) (HAdron InDex COnversion)
29434 * translation table version filled up by r.e. 25.01.94 *
29436 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
29437 &13,130,211,-211,321, -321,3122,-3122,310,3112,
29438 &3222,3212,111,311,-311, 0,0,0,0,0,
29439 &221,213,113,-213,223, 323,313,-323,-313,10323,
29440 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
29441 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
29442 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
29443 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
29445 &4*99999,331, 333,3322,3312,-3222,-3212,
29446 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
29447 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
29448 &-431,441,423,413,-413, -423,433,-433,20443,443,
29449 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
29450 &4212,4112,3*99999, 3*99999,-4122,-4232,
29451 &-4132,-4222,-4212,-4112,99999, 5*99999,
29454 &5*99999 , 20211,20111,-20211,99999,20321,
29455 &-20321,20311,-20311,7*99999 ,
29456 &7*99999,12212,12112,99999/
29459 * (HAdron InDex COnversion)
29460 DATA (IPDG2(1,K),K=1,7)
29461 & / -11, -12, -13, -15, -16, -14, 0/
29462 DATA (IBAM2(1,K),K=1,7)
29463 & / 4, 6, 10, 131, 134, 136, 0/
29464 DATA (IPDG2(2,K),K=1,7)
29465 & / 11, 12, 22, 13, 15, 16, 14/
29466 DATA (IBAM2(2,K),K=1,7)
29467 & / 3, 5, 7, 11, 132, 133, 135/
29468 DATA (IPDG3(1,K),K=1,22)
29469 & / -211, -321, -311, -213, -323, -313, -411, -421,
29470 & -431, -413, -423, -433, 0, 0, 0, 0,
29471 & 0, 0, 0, 0, 0, 0/
29472 DATA (IBAM3(1,K),K=1,22)
29473 & / 14, 16, 25, 34, 38, 39, 118, 119,
29474 & 121, 125, 126, 128, 0, 0, 0, 0,
29475 & 0, 0, 0, 0, 0, 0/
29476 DATA (IPDG3(2,K),K=1,22)
29477 & / 130, 211, 321, 310, 111, 311, 221, 213,
29478 & 113, 223, 323, 313, 331, 333, 421, 411,
29479 & 431, 441, 423, 413, 433, 443/
29480 DATA (IBAM3(2,K),K=1,22)
29481 & / 12, 13, 15, 19, 23, 24, 31, 32,
29482 & 33, 35, 36, 37, 95, 96, 116, 117,
29483 & 120, 122, 123, 124, 127, 130/
29484 DATA (IPDG4(1,K),K=1,29)
29485 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
29486 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
29487 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
29488 & -4212, -4112, 0, 0, 0/
29489 DATA (IBAM4(1,K),K=1,29)
29490 & / 2, 9, 18, 67, 68, 69, 70, 75,
29491 & 76, 99, 100, 101, 102, 103, 110, 111,
29492 & 112, 113, 114, 115, 149, 150, 151, 152,
29493 & 153, 154, 0, 0, 0/
29494 DATA (IPDG4(2,K),K=1,29)
29495 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
29496 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
29497 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
29498 & 4232, 4132, 4222, 4212, 4112/
29499 DATA (IBAM4(2,K),K=1,29)
29500 & / 1, 8, 17, 20, 21, 22, 48, 49,
29501 & 50, 51, 52, 53, 54, 55, 56, 97,
29502 & 98, 104, 105, 106, 107, 108, 109, 137,
29503 & 138, 139, 140, 141, 142/
29504 DATA (IPDG5(1,K),K=1,19)
29505 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
29506 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
29508 DATA (IBAM5(1,K),K=1,19)
29509 & / 42, 43, 46, 47, 71, 72, 73, 74,
29510 & 188, 191, 193, 0, 0, 0, 0, 0,
29512 DATA (IPDG5(2,K),K=1,19)
29513 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
29514 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
29515 & 20311, 12212, 12112/
29516 DATA (IBAM5(2,K),K=1,19)
29517 & / 40, 41, 44, 45, 57, 58, 59, 60,
29518 & 63, 64, 65, 66, 129, 186, 187, 190,
29522 * internal particle names
29523 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
29524 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
29525 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
29526 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
29527 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
29528 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
29533 *===blkd46=============================================================*
29535 CDECK ID>, DT_BLKD46
29536 BLOCK DATA DT_BLKD46
29538 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29541 PARAMETER ( AMELCT = 0.51099906 D-03 )
29542 PARAMETER ( AMMUON = 0.105658389 D+00 )
29544 * particle properties (BAMJET index convention)
29546 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29547 & IICH(210),IIBAR(210),K1(210),K2(210)
29550 * Particle masses Engel version JETSET compatible
29551 DATA (AAM(K),K=1,85) /
29552 & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
29553 & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
29554 & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
29555 & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
29556 & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
29557 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29558 & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
29559 & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
29560 & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
29561 & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
29562 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
29563 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
29564 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
29565 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
29566 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
29567 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
29568 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
29569 DATA (AAM(K),K=86,183) /
29570 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
29571 & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
29572 & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
29573 & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
29574 & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
29575 & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
29576 & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
29577 & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
29578 & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
29579 & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
29580 & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
29581 & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
29582 & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
29583 & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
29584 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
29585 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
29586 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
29587 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
29588 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
29589 & .1250D+01, .1250D+01, .1250D+01 /
29590 DATA (AAM ( I ), I = 184,210 ) /
29591 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
29592 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
29593 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
29594 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
29595 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
29596 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
29597 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
29598 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
29599 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
29600 * Particle mean lives
29601 DATA (TAU(K),K=1,183) /
29602 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
29603 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
29604 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
29605 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
29606 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
29608 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
29609 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
29610 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
29611 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
29612 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29613 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29614 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29615 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
29616 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29618 & .0000D+00, .0000D+00, .0000D+00 /
29619 DATA ( TAU ( I ), I = 184,210 ) /
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 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
29628 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
29629 * Resonance width Gamma in GeV
29630 DATA (GA(K),K= 1,85) /
29632 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
29633 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
29634 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
29635 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
29636 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
29637 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
29638 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
29639 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
29640 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
29641 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
29642 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
29643 DATA (GA(K),K= 86,183) /
29644 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
29645 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
29646 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29647 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
29648 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
29649 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
29650 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
29651 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
29652 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
29654 & .3000D+00, .3000D+00, .3000D+00 /
29655 DATA ( GA ( I ), I = 184,210 ) /
29656 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
29657 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
29658 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
29659 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
29660 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
29661 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
29662 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
29663 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
29664 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
29666 * S+1385+Sigma+(1385) L02030+Lambda0(2030)
29667 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
29668 * designation N*@@ means N*@1(@2)
29669 DATA (ANAME(K),K=1,85) /
29670 & 'P ','AP ','E- ','E+ ','NUE ',
29671 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
29672 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
29673 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
29674 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
29675 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
29676 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
29677 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
29678 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
29679 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
29680 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
29681 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
29682 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
29683 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
29684 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
29685 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
29686 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
29687 DATA (ANAME(K),K=86,183) /
29688 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
29689 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
29690 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
29691 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
29692 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
29693 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
29694 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
29695 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
29696 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
29697 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
29698 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
29699 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
29700 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
29701 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
29702 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
29703 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
29704 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
29705 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
29706 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
29707 & 'RO ','R+ ','R- ' /
29708 DATA ( ANAME ( I ), I = 184,210 ) /
29709 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
29710 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
29711 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
29712 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
29713 &'N*+14 ','N*014 ','BLANK '/
29714 * Charge of particles and resonances
29715 DATA (IICH ( I ), I = 1,210 ) /
29716 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
29717 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29718 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
29719 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
29720 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
29721 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
29722 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
29723 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
29724 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
29725 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
29726 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
29727 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
29728 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
29729 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
29730 * Particle baryonic charges
29731 DATA (IIBAR ( I ), I = 1,210 ) /
29732 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
29733 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
29734 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29735 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29736 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
29737 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
29738 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
29739 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
29740 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29741 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
29742 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
29743 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
29744 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
29745 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
29746 * First number of decay channels used for resonances
29747 * and decaying particles
29748 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
29749 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
29750 & 2*330, 46, 51, 52, 54, 55, 58,
29752 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
29753 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
29754 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
29756 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
29757 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
29758 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
29759 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
29760 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
29761 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
29762 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
29763 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
29764 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
29765 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
29767 * Last number of decay channels used for resonances
29768 * and decaying particles
29769 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
29770 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
29771 & 2* 330, 50, 51, 53, 54, 57,
29773 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
29774 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
29775 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
29777 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
29778 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
29779 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
29780 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
29781 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
29782 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
29783 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
29784 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
29785 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
29786 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
29787 & 589, 595, 601, 602 /
29791 *===blkd47=============================================================*
29793 CDECK ID>, DT_BLKD47
29794 BLOCK DATA DT_BLKD47
29796 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29799 * HADRIN: decay channel information
29800 PARAMETER (IDMAX9=602)
29802 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
29804 * Name of decay channel
29805 * Designation N*@ means N*@1(1236)
29806 * @1=# means ++, @1 = = means --
29807 * Designation P+/0/- means Pi+/Pi0/Pi- , respectively
29808 DATA (ZKNAME(K),K= 1, 85) /
29809 & 'P ','AP ','E- ','E+ ','NUE ',
29810 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
29811 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
29812 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
29813 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
29814 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
29815 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
29816 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
29817 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
29818 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
29819 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
29820 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
29821 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
29822 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
29823 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
29824 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
29825 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
29826 DATA (ZKNAME(K),K= 86,170) /
29827 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
29828 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
29829 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
29830 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
29831 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
29832 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
29833 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
29834 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
29835 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
29836 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
29837 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
29838 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
29839 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
29840 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
29841 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
29842 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
29843 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
29844 DATA (ZKNAME(K),K=171,255) /
29845 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
29846 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
29847 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
29848 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
29849 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
29850 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
29851 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
29852 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
29853 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
29854 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
29855 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
29856 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
29857 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
29858 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
29859 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
29860 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
29861 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
29862 DATA (ZKNAME(K),K=256,340) /
29863 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
29864 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
29865 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
29866 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
29867 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
29868 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
29869 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
29870 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
29871 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
29872 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
29873 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
29874 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
29875 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
29876 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
29877 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
29878 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
29879 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
29880 DATA (ZKNAME(K),K=341,425) /
29881 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
29882 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
29883 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
29884 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
29885 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
29886 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
29887 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
29888 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
29889 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
29890 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
29891 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
29892 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
29893 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
29894 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
29895 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
29896 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
29897 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
29898 DATA (ZKNAME(K),K=426,510) /
29899 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
29900 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
29901 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
29902 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
29903 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
29904 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
29905 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
29906 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
29907 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
29908 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
29909 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
29910 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
29911 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
29912 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
29913 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
29914 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
29915 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
29916 DATA (ZKNAME(K),K=511,540) /
29917 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
29918 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
29919 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
29920 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
29921 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
29922 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
29923 DATA (ZKNAME(I),I=541,602)/
29924 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
29925 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
29926 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
29927 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
29928 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
29929 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
29930 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
29931 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
29932 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
29933 * Weight of decay channel
29934 DATA (WT(K),K= 1, 85) /
29935 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
29936 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
29937 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
29938 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
29939 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
29940 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
29941 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
29942 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
29943 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
29944 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
29945 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
29946 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
29947 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
29948 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
29949 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
29950 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
29951 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
29952 DATA (WT(K),K= 86,170) /
29953 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
29954 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
29955 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
29956 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
29957 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
29958 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
29959 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
29960 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
29961 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
29962 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
29963 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
29964 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
29965 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
29966 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
29967 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
29968 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
29969 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
29970 DATA (WT(K),K=171,255) /
29971 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
29972 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
29973 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
29974 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
29975 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
29976 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
29977 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
29978 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
29979 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
29980 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
29981 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
29982 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
29983 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
29984 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
29985 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
29986 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
29987 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
29988 DATA (WT(K),K=256,340) /
29989 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
29990 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
29991 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
29992 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
29993 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
29994 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
29995 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
29996 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
29997 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
29998 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
29999 & .5000D-01, .5000D-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 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30003 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30004 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
30005 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
30006 DATA (WT(K),K=341,425) /
30007 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
30008 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
30009 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
30010 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
30011 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
30012 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
30013 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
30014 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
30015 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
30016 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
30017 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
30018 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
30019 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
30020 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
30021 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
30022 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
30023 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
30024 DATA (WT(K),K=426,510) /
30025 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
30026 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
30027 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
30028 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
30029 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
30030 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
30031 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30032 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
30033 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
30034 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
30035 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
30036 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
30037 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
30038 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
30039 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
30040 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
30041 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
30042 DATA (WT(K),K=511,540) /
30043 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30044 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
30045 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30046 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
30047 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
30048 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
30050 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
30051 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
30052 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
30053 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
30054 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
30055 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
30056 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
30057 * Particle numbers in decay channel
30058 DATA (NZK(K,1),K= 1,170) /
30059 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
30060 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
30061 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
30062 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
30063 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
30064 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
30065 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
30066 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
30067 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
30068 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
30069 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
30070 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
30071 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
30072 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
30073 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
30074 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
30075 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
30076 DATA (NZK(K,1),K=171,340) /
30077 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
30078 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
30079 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
30080 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
30081 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
30082 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
30083 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
30084 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
30085 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
30086 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
30087 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
30088 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
30089 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
30090 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
30091 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30092 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30093 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
30094 DATA (NZK(K,1),K=341,510) /
30095 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
30096 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
30097 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
30098 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
30099 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
30100 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
30101 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
30102 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
30103 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
30104 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
30105 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
30106 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
30107 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
30108 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
30109 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
30110 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
30111 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
30112 DATA (NZK(K,1),K=511,540) /
30113 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
30114 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
30115 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
30116 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
30117 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
30118 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
30119 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
30120 & 55, 8, 1, 8, 8, 54, 55, 210/
30121 DATA (NZK(K,2),K= 1,170) /
30122 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
30123 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
30124 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
30125 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
30126 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
30127 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
30128 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
30129 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
30130 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
30131 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
30132 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
30133 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
30134 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
30135 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
30136 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
30137 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
30138 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
30139 DATA (NZK(K,2),K=171,340) /
30140 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
30141 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
30142 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
30143 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
30144 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
30145 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
30146 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
30147 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
30148 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
30149 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
30150 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
30151 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
30152 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
30153 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
30154 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30155 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30156 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
30157 DATA (NZK(K,2),K=341,510) /
30158 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
30159 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
30160 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
30161 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
30162 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
30163 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
30164 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
30165 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
30166 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
30167 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
30168 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
30169 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
30170 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
30171 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
30172 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
30173 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
30174 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
30175 DATA (NZK(K,2),K=511,540) /
30176 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
30177 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
30178 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
30179 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
30180 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
30181 & 14, 14, 23, 14, 16, 25,
30182 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
30183 & 23, 13, 14, 23, 0 /
30184 DATA (NZK(K,3),K= 1,170) /
30185 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
30186 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
30187 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
30188 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
30189 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
30190 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
30192 DATA (NZK(K,3),K=171,340) /
30194 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
30195 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
30196 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
30197 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
30198 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
30200 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
30201 DATA (NZK(K,3),K=341,510) /
30203 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
30204 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
30205 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
30206 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30207 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
30208 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
30210 DATA (NZK(K,3),K=511,540) /
30211 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
30212 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30213 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
30214 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
30215 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
30220 *====phoini============================================================*
30222 CDECK ID>, DT_XHOINI
30223 SUBROUTINE DT_XHOINI
30224 C SUBROUTINE DT_PHOINI
30226 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30229 PARAMETER ( LINP = 5 ,
30236 *====eventb============================================================*
30238 CDECK ID>, DT_XVENTB
30239 SUBROUTINE DT_XVENTB(NCSY,IREJ)
30240 C SUBROUTINE DT_EVENTB(NCSY,IREJ)
30242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30245 PARAMETER ( LINP = 5 ,
30250 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
30255 *===event==============================================================*
30257 CDECK ID>, DT_XVENT
30258 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
30259 C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
30261 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30264 DIMENSION PP(4),PT(4)
30269 *===pohisx=============================================================*
30271 CDECK ID>, DT_XOHISX
30272 SUBROUTINE DT_XOHISX(I,X)
30273 C SUBROUTINE POHISX(I,X)
30275 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30281 *===poluhi=============================================================*
30284 C SUBROUTINE XOLUHI(I,X)
30287 CDECK ID>, PHO_LHIST
30288 SUBROUTINE PHO_LHIST(I,X)
30292 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30299 C**********************************************************************
30301 C dummy subroutines, remove to link PDFLIB
30303 C**********************************************************************
30304 SUBROUTINE PDFSET(PARAM,VALUE)
30305 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30306 DIMENSION PARAM(20),VALUE(20)
30310 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
30311 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30314 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
30315 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30318 *===diqbrk=============================================================*
30320 CDECK ID>, DT_DIQBRK
30321 SUBROUTINE DT_XIQBRK
30322 C SUBROUTINE DT_DIQBRK
30324 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30327 STOP 'diquark-breaking not implemeted !'
30332 *===pho_rndm===========================================================*
30334 CDECK ID>, PHO_RNDM
30335 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
30337 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30340 PHO_RNDM = DT_RNDM(DUMMY)
30345 *===pyr================================================================*
30348 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
30350 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30353 DUMMY = DBLE(IDUMMY)
30354 PYR = DT_RNDM(DUMMY)
30359 *===elhain=============================================================*
30361 CDECK ID>, DT_ELHAIN
30362 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
30364 ************************************************************************
30365 * Elastic hadron-hadron scattering. *
30366 * This is a revised version of the original. *
30367 * This version dated 03.04.98 is written by S. Roesler *
30368 ************************************************************************
30370 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30373 PARAMETER ( LINP = 5 ,
30377 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
30380 PARAMETER (ENNTHR = 3.5D0)
30381 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
30382 & BLOWB=0.05D0,BHIB=0.2D0,
30383 & BLOWM=0.1D0, BHIM=2.0D0)
30385 * particle properties (BAMJET index convention)
30387 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
30388 & IICH(210),IIBAR(210),K1(210),K2(210)
30389 * final state from HADRIN interaction
30390 PARAMETER (MAXFIN=10)
30391 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
30392 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
30394 C DATA TSLOPE /10.0D0/
30400 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
30401 EKIN = ELAB-AAM(IP)
30402 * kinematical quantities in cms of the hadrons
30405 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
30407 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
30408 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
30410 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
30411 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
30412 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
30413 * TSAMCS treats pp and np only, therefore change pn into np and
30419 IF (IP.EQ.8) KPROJ = 1
30421 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
30422 T = TWO*PCM**2*(CTCMS-ONE)
30424 * very crude treatment otherwise: sample t from exponential dist.
30426 * momentum transfer t
30427 TMAX = TWO*TWO*PCM**2
30428 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
30429 IF (IIBAR(IP).NE.0) THEN
30430 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
30432 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
30434 FMAX = EXP(-TSLOPE*TMAX)-ONE
30436 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
30437 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
30440 * target hadron in Lab after scattering
30441 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
30442 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
30443 IF (PLRH(2).LE.TINY10) THEN
30444 C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
30447 * projectile hadron in Lab after scattering
30448 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
30449 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
30450 * scattering angle of projectile in Lab
30451 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
30452 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
30453 CALL DT_DSFECF(SPLABP,CPLABP)
30454 * direction cosines of projectile in Lab
30455 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
30456 & CXRH(1),CYRH(1),CZRH(1))
30457 * scattering angle of target in Lab
30458 PLLABT = PLAB-CTLABP*PLRH(1)
30459 CTLABT = PLLABT/PLRH(2)
30460 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
30461 * direction cosines of target in Lab
30462 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
30463 & CXRH(2),CYRH(2),CZRH(2))
30472 *===tsamcs=============================================================*
30474 CDECK ID>, DT_TSAMCS
30475 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
30477 ************************************************************************
30478 * Sampling of cos(theta) for nucleon-proton scattering according to *
30479 * hetkfa2/bertini parametrization. *
30480 * This is a revised version of the original (HJM 24/10/88) *
30481 * This version dated 28.10.95 is written by S. Roesler *
30482 ************************************************************************
30484 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30487 PARAMETER ( LINP = 5 ,
30491 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
30494 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
30495 DIMENSION PDCI(60),PDCH(55)
30497 DATA (DCLIN(I),I=1,80) /
30498 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
30499 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
30500 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
30501 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
30502 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
30503 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
30504 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
30505 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
30506 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
30507 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
30508 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
30509 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
30510 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
30511 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
30512 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
30513 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
30514 DATA (DCLIN(I),I=81,160) /
30515 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
30516 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
30517 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
30518 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
30519 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
30520 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
30521 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
30522 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
30523 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
30524 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
30525 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
30526 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
30527 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
30528 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
30529 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
30530 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
30531 DATA (DCLIN(I),I=161,195) /
30532 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
30533 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
30534 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
30535 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
30536 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
30537 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
30538 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
30541 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
30542 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
30543 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
30544 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
30545 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
30546 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
30547 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
30548 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
30549 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
30550 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
30551 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
30552 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
30555 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
30556 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
30557 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
30558 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
30559 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
30560 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
30561 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
30562 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
30563 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
30564 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
30565 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
30567 DATA (DCHN(I),I=1,90) /
30568 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
30569 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
30570 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
30571 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
30572 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
30573 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
30574 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
30575 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
30576 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
30577 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
30578 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
30579 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
30580 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
30581 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
30582 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
30583 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
30584 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
30585 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
30586 DATA (DCHN(I),I=91,143) /
30587 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
30588 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
30589 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
30590 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
30591 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
30592 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
30593 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
30594 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
30595 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
30596 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
30597 & 6.488D-02, 6.485D-02, 6.480D-02/
30600 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
30601 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
30602 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
30603 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
30604 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
30605 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
30606 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
30610 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
30611 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
30612 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
30613 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
30614 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
30615 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
30616 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
30617 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
30618 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
30619 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
30620 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
30621 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
30624 IF (EKIN.GT.3.5D0) RETURN
30626 IF(KPROJ.EQ.8) GOTO 101
30627 IF(KPROJ.EQ.1) GOTO 102
30628 C* INVALID REACTION
30629 WRITE(LOUT,'(A,I5/A)')
30630 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
30631 & ' COS(THETA) = 1D0 RETURNED'
30633 C-------------------------------- NP ELASTIC SCATTERING----------
30635 IF (EKIN.GT.0.740D0)GOTO 1000
30636 IF (EKIN.LT.0.300D0)THEN
30637 C EKIN .LT. 300 MEV
30640 C 300 MEV < EKIN < 740 MEV
30645 IE=INT(ABS(ENER/0.020D0))
30646 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
30647 C FORWARD/BACKWARD DECISION
30649 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
30650 IF (DT_RNDM(CST).LT.BWFW)THEN
30658 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
30661 IF(RND.LT.COEF)THEN
30670 IF(VALUE2.GT.0.0)THEN
30671 CST=MAX(R1,R2,R3,R4)
30677 CST=-MAX(R1,R2,R3,R4,R5)
30681 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
30690 C******** EKIN .GT. 0.74 GEV
30692 1000 ENER=EKIN - 0.66D0
30693 C IE=ABS(ENER/0.02)
30694 IE=INT(ENER/0.02D0)
30697 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
30699 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
30702 IF (RND.GE.BWFW)THEN
30704 IF (DCHNA(K).GT.EMEV) THEN
30705 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
30706 UNIV=DT_RNDM(UNIVE)
30709 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
30712 UNIV=DT_RNDM(UNIVE)
30714 GOTO(290,290,290,290,330,340,350,360) I
30723 IF (DCHNB(K).GT.EMEV) THEN
30724 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
30725 UNIV=DT_RNDM(UNIVE)
30728 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
30733 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
30740 120 CST=1.0D-2*FLTI-1.0D0
30742 140 CST=2.0D-2*UNIV-0.98D0
30744 150 CST=4.0D-2*UNIV-0.96D0
30746 160 CST=6.0D-2*FLTI-1.16D0
30748 180 CST=8.0D-2*UNIV-0.80D0
30750 190 CST=1.0D-1*UNIV-0.72D0
30752 200 CST=1.2D-1*UNIV-0.62D0
30754 210 CST=2.0D-1*UNIV-0.50D0
30756 220 CST=3.0D-1*(UNIV-1.0D0)
30759 290 CST=1.0D0-2.5d-2*FLTI
30761 330 CST=0.85D0+0.5D-1*UNIV
30763 340 CST=0.70D0+1.5D-1*UNIV
30765 350 CST=0.50D0+2.0D-1*UNIV
30767 360 CST=0.50D0*UNIV
30771 C----------------------------------- PP ELASTIC SCATTERING -------
30776 IF (EKIN.LE.0.500D0) THEN
30778 CST=2.0D0*RND-1.0D0
30781 ELSEIF (EKIN.LT.1.0D0) THEN
30783 IF (PDCI(K).GT.EMEV) THEN
30784 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
30785 UNIV=DT_RNDM(UNIVE)
30789 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
30791 IF (UNIV.LT.SUM)THEN
30794 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
30801 IF (PDCH(K).GT.EMEV) THEN
30802 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
30803 UNIV=DT_RNDM(UNIVE)
30807 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
30809 IF (UNIV.LT.SUM)THEN
30812 GOTO(50,55,60,60,65,65,65,65,70,70) I
30823 60 CST=0.3D0+0.1D0*FLTI
30825 65 CST=0.6D0+0.04D0*FLTI
30827 70 CST=0.78D0+0.02D0*FLTI
30830 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
30835 *===dhadri=============================================================*
30837 CDECK ID>, DT_DHADRI
30838 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
30840 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30843 PARAMETER ( LINP = 5 ,
30848 C-----------------------------
30849 C*** INPUT VARIABLES LIST:
30850 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
30851 C*** GEV/C LABORATORY MOMENTUM REGION
30852 C*** N - PROJECTILE HADRON INDEX
30853 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
30854 C*** ELAB - LABORATORY ENERGY OF N (GEV)
30855 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
30856 C*** ITTA - TARGET NUCLEON INDEX
30857 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
30858 C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
30859 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
30860 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
30861 C*** RESPECT., UNITS (GEV/C AND GEV)
30862 C----------------------------
30864 COMMON /HNGAMR/ REDU,AMO,AMM(15)
30865 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
30866 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
30867 & NRK(2,268),NURE(30,2)
30868 * particle properties (BAMJET index convention),
30869 * (dublicate of DTPART for HADRIN)
30870 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
30871 & K1H(110),K2H(110)
30872 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
30873 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
30875 COMMON /HNDRUN/ RUNTES,EFTES
30876 * particle properties (BAMJET index convention)
30878 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
30879 & IICH(210),IIBAR(210),K1(210),K2(210)
30880 * final state from HADRIN interaction
30881 PARAMETER (MAXFIN=10)
30882 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
30883 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
30885 DIMENSION ITPRF(110)
30888 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
30890 IF (N.LE.0.OR.N.GE.111)N=1
30891 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
30894 * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
30896 *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
30897 * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
30900 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
30901 C IF(IPRI.GE.1) WRITE (6,1010) PLAB
30903 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
30904 + ALLOWED REGION, PLAB=',1E15.5)
30907 UMODAT=N*1.11111D0+ITTA*2.19291D0
30908 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
30915 IF (LOWP.GT.20) THEN
30916 C WRITE(LOUT,*) ' jump 1'
30920 IF (NNN.EQ.N) GO TO 50
30929 IF(ITTA.GT.1) IRE=NURE(N,2)
30931 C-----------------------------
30932 C*** IE,AMT,ECM,SI DETERMINATION
30933 C----------------------------
30934 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
30937 C IF (AMH(1).NE.0.93828D0) IANTH=1
30938 IF (AMH(1).NE.0.9383D0) IANTH=1
30940 IF (IANTH.GE.0) SI=1.0D0
30943 C-----------------------------
30945 C IRE CHARACTERIZES THE REACTION
30946 C IE IS THE ENERGY INDEX
30947 C----------------------------
30948 IF (SI.LT.1.D-6) THEN
30949 C WRITE(LOUT,*) ' jump 2'
30952 IF (N.LE.NSTAB) GO TO 60
30953 RUNTES=RUNTES+1.0D0
30954 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
30955 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
30956 IF(IBARH(N).EQ.1) N=8
30957 IF(IBARH(N).EQ.-1) N=9
30960 **sr 19.2.97: loop for direct channel suppression
30961 C IF (IMACH.GT.10) THEN
30962 IF (IMACH.GT.1000) THEN
30964 C WRITE(LOUT,*) ' jump 3'
30970 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
30971 IF(ECMN.LE.AMN) ECMN=AMN
30972 PCMN=SQRT(ECMN**2-AMN2)
30975 IF (IANTH.GE.0) ECM=2.1D0
30977 C-----------------------------
30978 C*** RANDOM CHOICE OF REACTION CHANNEL
30979 C----------------------------
30984 C-----------------------------
30985 C*** PLACE REDUCED VERSION
30986 C----------------------------
30988 IDWK=IEII(IRE+1)-IIEI
30992 C-----------------------------
30993 C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
30994 C----------------------------
30996 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
30997 IF (HUMO.LT.ECM) ECM=HUMO
30999 C-----------------------------
31000 C*** INTERPOLATION PREPARATION
31001 C----------------------------
31007 C-----------------------------
31009 C----------------------------
31014 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
31018 C-----------------------------
31019 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
31020 C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
31022 C----------------------------
31023 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
31024 WICO=WOK*1.23459876D0+WDK*1.735218469D0
31025 IF (WICO.EQ.WICOR) GO TO 70
31026 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
31029 C-----------------------------
31030 C*** INTERPOLATION IN CHANNEL WEIGHTS
31031 C----------------------------
31032 EKLIM=-THRESH(IIKI+IK)
31033 IELIM=IDT_IEFUND(EKLIM,IRE)
31034 DELIM=UMO(IELIM)+EKLIM
31036 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
31037 IF (DELIM*DELIM-DETE*DETE) 90,90,80
31042 WKK=WOK-WDK*DEC/(DECC+1.D-9)
31044 C-----------------------------
31046 C----------------------------
31048 IF (VV.GT.WKK) GO TO 70
31050 C***IK IS THE REACTION CHANNEL
31051 C----------------------------
31063 IF (I1001.GT.50) GO TO 60
31065 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
31068 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
31071 IF (IT2.GT.0) GO TO 120
31072 **sr 19.2.97: supress direct channel for pp-collisions
31073 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
31075 IF (RR.LE.0.75D0) GOTO 60
31079 C-----------------------------
31080 C INCLUSION OF DIRECT RESONANCES
31081 C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
31082 C------------------------
31095 IF(WW.LT. 0.5D0) GO TO 130
31102 C-----------------------------
31103 C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
31110 IF(IB1.EQ.IBN) GO TO 140
31116 C-----------------------------
31117 C***IT1,IT2 ARE THE CREATED PARTICLES
31118 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
31119 C------------------------
31120 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
31121 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
31126 C-----------------------------
31127 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
31128 C----------------------------
31129 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
31130 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31134 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
31135 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31138 C-----------------------------
31139 C***TEST STABLE OR UNSTABLE
31140 C----------------------------
31141 IF(ITS(IST).GT.NSTAB) GO TO 160
31144 C-----------------------------
31145 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
31146 C----------------------------
31147 C* IF (REDU.LT.0.D0) GO TO 1009
31155 IF(IST.GE.1) GO TO 150
31159 C RANDOM CHOICE OF DECAY CHANNELS
31160 C----------------------------
31174 IF (VV.GT.WTI(IIK)) GO TO 180
31176 C IIK IS THE DECAY CHANNEL
31177 C----------------------------
31185 IF (IT2-1.LT.0) GO TO 240
31190 C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
31191 C----------------------------
31192 IF (IECO.LE.10) GO TO 200
31194 IF(IATMPT.GT.3) THEN
31195 C WRITE(LOUT,*) ' jump 4'
31200 IF (I310.GT.50) GO TO 170
31201 IF (AMS.GT.ECO) GO TO 190
31203 C FOR THE DECAY CHANNEL
31204 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
31205 C----------------------------
31206 IF (REDU.LT.0.D0) GO TO 30
31209 IF(IT3.EQ.0) GO TO 220
31212 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
31213 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
31215 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
31216 &COD2,COF2,SIF2,AM1,AM2)
31221 IF (REDU.GT.0.D0) GO TO 240
31223 IF (ITWTHC.GT.100) GO TO 30
31224 IF (ITWTH) 220,220,210
31227 IF (IT2-1.LT.0) GO TO 250
31234 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
31235 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31238 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
31239 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31240 IF (IT3.LE.0) GO TO 250
31243 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
31244 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
31252 C----------------------------
31254 C ZERO CROSS SECTION CASE
31255 C----------------------------
31267 *===runtt==============================================================*
31269 CDECK ID>, DT_RUNTT
31270 BLOCK DATA DT_RUNTT
31272 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31275 COMMON /HNDRUN/ RUNTES,EFTES
31277 DATA RUNTES,EFTES /100.D0,100.D0/
31281 *===noname=============================================================*
31283 CDECK ID>, DT_NONAME
31284 BLOCK DATA DT_NONAME
31286 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31289 * slope parameters for HADRIN interactions
31290 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
31291 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31293 C DATAS DATAS DATAS DATAS DATAS
31295 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
31296 & 207, 224, 241, 252, 268 /
31297 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
31298 & 220, 241, 262, 279, 296 /
31299 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
31300 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
31303 C MASSES FOR THE SLOPE B(M) IN GEV
31304 C SLOPE B(M) FOR AN MESONIC SYSTEM
31305 C SLOPE B(M) FOR A BARYONIC SYSTEM
31308 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
31309 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
31310 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
31311 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
31312 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
31313 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
31314 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
31315 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
31316 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
31317 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
31318 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
31319 & 14.2D0, 13.4D0, 12.6D0,
31320 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
31321 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
31325 *===damg===============================================================*
31328 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
31330 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31333 * particle properties (BAMJET index convention),
31334 * (dublicate of DTPART for HADRIN)
31335 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31336 & K1H(110),K2H(110)
31338 DIMENSION GASUNI(14)
31340 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
31341 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
31342 DATA GAUNO/2.352D0/
31348 IF (IT.LE.0) GO TO 30
31349 IF (IT.LE.NSTAB) GO TO 20
31350 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
31352 VV=VV*2.0D0-1.0D0+1.D-16
31357 IF (VV.GT.V1) GO TO 10
31358 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
31359 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
31360 DAM=GAH(IT)*UNIGA/GAUNO
31372 *===dcalum=============================================================*
31374 CDECK ID>, DT_DCALUM
31375 SUBROUTINE DT_DCALUM(N,ITTA)
31377 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31380 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
31382 * particle properties (BAMJET index convention),
31383 * (dublicate of DTPART for HADRIN)
31384 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31385 & K1H(110),K2H(110)
31386 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31387 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
31388 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31389 & NRK(2,268),NURE(30,2)
31391 IRE=NURE(N,ITTA/8+1)
31400 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
31407 IF(NRK(2,IK).GT.0) GO TO 30
31416 IF(IN.GT.0)AMS=AMS+AMH(IN)
31418 IF(IN.GT.0) AMS=AMS+AMH(IN)
31419 IF (AMS.LT.AMSS) AMSS=AMS
31421 IF(UMOO.LT.AMSS) UMOO=AMSS
31427 *===dchanh=============================================================*
31429 CDECK ID>, DT_DCHANH
31430 SUBROUTINE DT_DCHANH
31432 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31435 PARAMETER ( LINP = 5 ,
31439 * particle properties (BAMJET index convention),
31440 * (dublicate of DTPART for HADRIN)
31441 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31442 & K1H(110),K2H(110)
31443 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
31444 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31445 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31446 & NRK(2,268),NURE(30,2)
31448 DIMENSION HWT(460),HWK(40),SI(5184)
31449 EQUIVALENCE (WK(1),SI(1))
31450 C--------------------
31451 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
31452 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
31453 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
31454 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
31455 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
31456 C--------------------------
31460 IEE=IEII(IRE+1)-IEII(IRE)
31461 IKE=IKII(IRE+1)-IKII(IRE)
31464 * modifications to suppress elestic scattering 24/07/91
31469 IWK=IWKO+IEE*(IK-1)+IE
31470 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
31471 SIS=SIS+SI(IWK)*SINORC
31475 IF (SIS.GE.1.D-12) GO TO 20
31481 IWK=IWKO+IEE*(IK-1)+IE
31482 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
31483 SIO=SIO+SI(IWK)*SINORC/SIS
31487 IWK=IWKO+IEE*(IK-1)+IE
31492 INRK1=NRK(1,IIKI+IK)
31493 IF (INRK1.GT.0) AM111=AMH(INRK1)
31495 INRK2=NRK(2,IIKI+IK)
31496 IF (INRK2.GT.0) AM222=AMH(INRK2)
31497 THRESH(IIKI+IK)=AM111 +AM222
31498 IF (INRK2-1.GE.0) GO TO 60
31502 DO 50 INRK1=INRKK,INRKO
31503 INZK1=NZKI(INRK1,1)
31504 INZK2=NZKI(INRK1,2)
31505 INZK3=NZKI(INRK1,3)
31506 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
31507 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
31508 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
31509 C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
31511 AMS=AMH(INZK1)+AMH(INZK2)
31512 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
31513 IF (AMSS.GT.AMS) AMSS=AMS
31516 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
31517 THRESH(IIKI+IK)=AMS
31528 IF (IK2.GT.460)IK2=460
31535 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
31536 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
31543 *===dhadde=============================================================*
31545 CDECK ID>, DT_DHADDE
31546 SUBROUTINE DT_DHADDE
31548 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31551 * particle properties (BAMJET index convention)
31553 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31554 & IICH(210),IIBAR(210),K1(210),K2(210)
31555 * HADRIN: decay channel information
31556 PARAMETER (IDMAX9=602)
31558 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31559 * particle properties (BAMJET index convention),
31560 * (dublicate of DTPART for HADRIN)
31561 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31562 & K1H(110),K2H(110)
31563 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
31564 * decay channel information for HADRIN
31565 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
31566 & K1Z(16),K2Z(16),WTZ(153),II22,
31567 & NZK1(153),NZK2(153),NZK3(153)
31573 IF (IRETUR.GT.1) RETURN
31579 IBARH(I) = IIBAR(I)
31594 NZKI(I,1) = NZK(I,1)
31595 NZKI(I,2) = NZK(I,2)
31596 NZKI(I,3) = NZK(I,3)
31611 NZKI(L,3) = NZK3(I)
31612 NZKI(L,2) = NZK2(I)
31613 NZKI(L,1) = NZK1(I)
31618 *===iefund=============================================================*
31620 CDECK ID>, IDT_IEFUND
31621 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
31623 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31626 C*****IEFUN CALCULATES A MOMENTUM INDEX
31628 PARAMETER ( LINP = 5 ,
31632 COMMON /HNDRUN/ RUNTES,EFTES
31633 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31634 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31635 & NRK(2,268),NURE(30,2)
31640 IF (PL.LT.0.) GO TO 30
31643 IF (PL.LE.PLABF(I)) GO TO 60
31646 IF ( EFTES.GT.40.D0) GO TO 20
31648 WRITE(LOUT,1000)PL,J
31654 IF (-PL.LE.UMO(I)) GO TO 60
31657 IF ( EFTES.GT.40.D0) GO TO 50
31659 WRITE(LOUT,1000)PL,I
31665 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
31669 *===dsigin=============================================================*
31671 CDECK ID>, DT_DSIGIN
31672 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
31674 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31677 * particle properties (BAMJET index convention),
31678 * (dublicate of DTPART for HADRIN)
31679 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31680 & K1H(110),K2H(110)
31681 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
31682 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31683 & NRK(2,268),NURE(30,2)
31685 IE=IDT_IEFUND(PLAB,IRE)
31686 IF (IE.LE.IEII(IRE)) IE=IE+1
31691 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
31692 C*** INTERPOLATION PREPARATION
31698 EKLIM=-THRESH(IIKI)
31701 IF (ECM.GT.ECMO) WDK=0.0D0
31702 C*** INTERPOLATION IN CHANNEL WEIGHTS
31703 IELIM=IDT_IEFUND(EKLIM,IRE)
31704 DELIM=UMO(IELIM)+EKLIM
31706 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
31707 IF (DELIM*DELIM-DETE*DETE) 20,20,10
31712 WKK=WOK-WDK*DEC/(DECC+1.D-9)
31713 IF (WKK.LT.0.0D0) WKK=0.0D0
31715 IF (-EKLIM.GT.ECM) SI=1.D-14
31719 *===dtchoi=============================================================*
31721 CDECK ID>, DT_DTCHOI
31722 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
31724 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31727 C ****************************
31728 C TCHOIC CALCULATES A RANDOM VALUE
31729 C FOR THE FOUR-MOMENTUM-TRANSFER T
31730 C ****************************
31732 * particle properties (BAMJET index convention),
31733 * (dublicate of DTPART for HADRIN)
31734 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31735 & K1H(110),K2H(110)
31736 * slope parameters for HADRIN interactions
31737 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
31741 IF (I.GT.30.AND.II.GT.30) GO TO 20
31744 IF (I.LE.30) GO TO 10
31752 IF (AMA.LE.AMB) GO TO 30
31758 K=INT((AMA-0.75D0)/0.05D0)
31760 IF (K-26.GE.0) K=25
31767 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
31768 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
31771 C IF (VB.LT.0.2D0) BM=BM*0.1
31778 IF (ABS(TMA).GT.120.D0) GO TO 70
31781 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
31782 C*** RANDOM CHOICE OF THE T - VALUE
31784 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
31788 *===dtwopa=============================================================*
31790 CDECK ID>, DT_DTWOPA
31791 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
31792 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
31794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31797 C ******************************************************
31798 C QUASI TWO PARTICLE PRODUCTION
31799 C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
31800 C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
31801 C IN THE CM - SYSTEM
31802 C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
31803 C SPHERICAL COORDINATES
31804 C ******************************************************
31806 * particle properties (BAMJET index convention),
31807 * (dublicate of DTPART for HADRIN)
31808 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
31809 & K1H(110),K2H(110)
31814 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
31816 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
31817 AMTE=(E1-AMA)*(E1+AMA)
31821 C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
31822 C DETERMINATION OF THE ANGLES
31823 C COS(THETA1)=COD1 COS(THETA2)=COD2
31824 C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
31825 C COS(PHI1)=COF1 COS(PHI2)=COF2
31826 C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
31827 CALL DT_DSFECF(COF1,SIF1)
31830 C CALCULATION OF THETA1
31831 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
31832 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
31833 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
31838 *===zk=================================================================*
31843 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31846 * decay channel information for HADRIN
31847 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
31848 & K1Z(16),K2Z(16),WTZ(153),II22,
31849 & NZK1(153),NZK2(153),NZK3(153)
31850 * decay channel information for HADRIN
31851 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
31852 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
31854 * Particle masses in GeV *
31855 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
31857 * Resonance width Gamma in GeV *
31858 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
31859 * Mean life time in seconds *
31860 DATA TAUZ / 16*0.D0 /
31861 * Charge of particles and resonances *
31862 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
31863 * Baryonic charge *
31864 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
31865 * First number of decay channels used for resonances *
31866 * and decaying particles *
31867 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
31869 * Last number of decay channels used for resonances *
31870 * and decaying particles *
31871 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
31873 * Weight of decay channel *
31874 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
31875 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
31876 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
31877 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
31878 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
31879 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
31880 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
31881 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
31882 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
31883 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
31884 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
31885 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
31886 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
31887 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
31888 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
31889 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
31890 & .05D0, .65D0, 9*1.D0 /
31891 * Particle numbers in decay channel *
31892 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
31893 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
31894 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
31895 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
31896 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
31897 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
31898 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
31899 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
31900 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
31901 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
31902 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
31903 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
31904 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
31905 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
31906 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
31907 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
31908 & 1, 8, 1, 8, 1, 9*0 /
31909 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
31910 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
31911 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
31912 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
31913 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
31914 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
31916 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
31917 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
31919 * Name of decay channel *
31920 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
31921 & 'ANNPI0','APPPI0','ANPPI-'/
31922 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
31923 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
31924 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
31925 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
31926 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
31927 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
31928 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
31930 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
31931 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
31932 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
31933 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
31934 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
31935 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
31936 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
31937 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
31938 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
31939 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
31940 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
31941 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
31942 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
31947 *===blkd43=============================================================*
31949 CDECK ID>, DT_BLKD43
31950 BLOCK DATA DT_BLKD43
31952 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31958 *=== reac =============================================================*
31960 *----------------------------------------------------------------------*
31962 * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
31965 * Last change on 10-dec-91 by Alfredo Ferrari *
31967 * This is the original common reac of Hadrin *
31969 *----------------------------------------------------------------------*
31971 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31972 & NRK(2,268),NURE(30,2)
31975 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
31976 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
31977 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
31978 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
31979 & SPIKP5(187), SPIKP6(289),
31980 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
31981 & SPIKP9(143), SPIKP0(169), SPKPV(143),
31982 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
31983 & SANPEL(84) , SPIKPF(273),
31984 & SPKP15(187), SPKP16(272),
31985 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
31988 DIMENSION NRKLIN(532)
31989 EQUIVALENCE (NRK(1,1), NRKLIN(1))
31990 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
31991 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
31992 EQUIVALENCE ( UMO(263), UMOK0(1))
31993 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
31994 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
31995 EQUIVALENCE ( PLABF(263), PLAK0(1))
31996 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
31997 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
31998 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
31999 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
32000 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
32001 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
32002 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
32003 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
32004 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
32005 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
32006 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
32007 EQUIVALENCE ( WK(4913), SPKP16(1))
32008 EQUIVALENCE (NRK(1,1), NRKLIN(1))
32009 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
32010 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
32011 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
32012 EQUIVALENCE (NURE(1,1), NURELN(1))
32016 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
32017 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
32018 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
32019 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
32020 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
32021 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
32022 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
32023 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
32024 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
32025 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
32027 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32028 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32029 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32030 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32031 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32032 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32033 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32034 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32035 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32036 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32037 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32038 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
32040 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32041 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32042 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
32043 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
32044 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
32045 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
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 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32053 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
32054 * app apn anp ann *
32056 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
32057 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32058 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
32059 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
32060 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32061 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
32062 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
32063 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
32064 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
32065 DATA SIIN / 296*0.D0 /
32066 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
32067 & 1.557D0,1.615D0,1.6435D0,
32068 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
32069 & 2.286D0,2.366D0,2.482D0,2.56D0,
32071 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
32072 & 1.496D0,1.527D0,1.557D0,
32073 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
32074 & 2.071D0,2.159D0,2.286D0,2.366D0,
32075 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
32076 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
32077 & 1.496D0,1.527D0,1.557D0,
32078 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
32079 & 2.071D0,2.159D0,2.286D0,2.366D0,
32080 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
32081 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
32082 & 1.557D0,1.615D0,1.6435D0,
32083 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
32084 & 2.286D0,2.366D0,2.482D0,2.56D0,
32086 DATA UMOKC/ 1.44D0,
32087 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32088 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32090 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32091 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32093 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32094 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32096 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32097 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32099 DATA UMOK0/ 1.44D0,
32100 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32101 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
32103 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
32104 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
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 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32113 & 3.D0,3.1D0,3.2D0/
32114 * app apn anp ann *
32116 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
32117 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32118 & 3.D0,3.1D0,3.2D0,
32119 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
32120 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32121 & 3.D0,3.1D0,3.2D0,
32122 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
32123 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
32124 & 3.D0,3.1D0,3.2D0/
32125 **** reaction channel state particles *
32126 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
32127 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
32128 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
32129 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
32130 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
32131 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
32132 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
32133 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
32134 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
32135 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
32136 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
32137 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
32138 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
32139 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
32140 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
32141 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
32142 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
32143 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
32145 * k0 p k0 n ak0 p ak/ n *
32147 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
32148 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
32149 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
32150 & 53, 47, 1, 103, 0, 93, 0/
32152 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
32153 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
32154 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
32155 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
32156 * app apn anp ann *
32157 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
32158 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
32159 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
32160 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
32161 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
32162 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
32163 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
32164 **** channel cross section *
32165 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
32166 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
32167 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
32168 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
32169 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
32170 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
32171 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
32172 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
32173 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
32174 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
32175 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
32176 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
32177 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
32178 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
32179 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
32180 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
32181 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
32182 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
32183 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
32184 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
32186 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
32187 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
32188 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
32189 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
32190 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
32191 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
32192 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
32193 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
32194 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
32195 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
32196 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
32197 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
32198 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
32199 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
32200 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
32201 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
32202 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
32203 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
32204 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
32205 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
32207 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
32208 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
32209 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
32210 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
32211 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
32212 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
32213 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
32214 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
32215 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
32216 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
32217 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
32218 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
32219 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
32220 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
32221 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
32222 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
32223 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
32224 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
32225 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
32226 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
32228 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
32229 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
32230 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
32231 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
32232 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
32233 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
32234 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
32235 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
32236 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
32237 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
32238 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
32239 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
32240 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
32241 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
32242 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
32243 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
32244 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
32245 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
32246 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
32248 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
32249 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
32250 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
32251 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
32252 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
32253 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
32254 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
32255 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
32256 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
32257 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
32258 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
32259 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
32260 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
32261 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
32262 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
32263 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
32264 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
32265 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
32266 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
32267 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
32269 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
32270 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
32271 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
32272 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
32273 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
32274 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
32275 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
32276 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
32277 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
32278 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
32279 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
32280 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
32281 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
32282 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
32283 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
32284 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
32285 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
32286 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
32287 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
32288 & 3.3D0, 5.4D0, 7.D0 /
32290 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
32291 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
32292 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
32293 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
32294 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
32295 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
32296 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
32297 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
32298 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
32299 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
32300 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
32301 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
32302 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
32304 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
32305 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
32306 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
32307 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
32308 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
32309 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
32310 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
32311 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
32312 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
32313 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
32314 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
32315 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
32316 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
32317 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
32318 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
32319 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
32320 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
32321 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
32322 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
32324 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
32325 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
32326 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
32327 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
32328 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
32329 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
32330 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
32331 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
32332 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
32333 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
32334 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
32335 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
32336 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
32337 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
32338 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
32339 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
32340 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
32341 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
32342 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
32343 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
32344 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
32345 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
32346 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
32347 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
32348 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
32349 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
32350 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
32351 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
32352 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
32353 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
32354 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
32355 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
32358 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
32359 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
32360 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
32361 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
32362 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
32363 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
32364 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
32365 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
32366 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
32367 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
32368 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
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 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
32372 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
32373 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
32374 & .39D0, .22D0, .07D0, 0.D0,
32375 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
32376 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
32377 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
32378 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
32379 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
32380 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
32381 & 5.10D0, 5.44D0, 5.3D0,
32382 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
32384 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
32385 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
32386 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
32387 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
32388 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
32389 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
32390 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
32391 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
32392 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
32393 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
32394 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
32395 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
32396 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
32397 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
32398 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
32400 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
32401 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
32402 & 0.D0, 1.8D0, .2D0, 12*0.D0,
32403 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
32404 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
32405 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
32406 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
32407 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
32408 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
32409 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
32410 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
32411 & 10*0.D0, .7D0, 5.1D0, 8.D0,
32412 & 10*0.D0, .7D0, 5.1D0, 8.D0,
32413 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
32414 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
32415 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
32416 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
32417 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
32420 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
32421 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
32422 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
32423 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
32424 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
32425 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
32426 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
32427 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
32428 & 11.D0, 5.5D0, 3.5D0,
32429 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
32430 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
32431 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
32432 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
32433 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
32434 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
32435 **************** ap - p - data *
32436 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
32437 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
32438 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
32439 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
32440 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
32441 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
32442 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
32443 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
32444 & 1.55D0, 1.3D0, .95D0, .75D0,
32445 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
32446 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
32447 & .01D0, .008D0, .006D0, .005D0/
32448 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
32449 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
32450 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
32451 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
32452 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
32453 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
32454 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
32455 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
32456 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
32457 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 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, 13*0.D0, 1.3D0,
32460 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
32461 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
32462 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
32463 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
32464 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
32465 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
32466 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
32467 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
32468 **************** ap - n - data *
32470 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
32471 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
32472 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
32473 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
32474 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
32475 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
32476 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
32477 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
32478 & .01D0, .008D0, .006D0, .005D0 /
32479 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
32480 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
32481 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
32482 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32483 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
32484 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
32485 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
32486 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32487 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32488 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32489 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
32490 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
32491 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
32492 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
32495 **************** an - p - data *
32498 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
32499 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
32500 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
32501 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
32502 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
32503 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
32504 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
32505 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
32506 & .01D0, .008D0, .006D0, .005D0 /
32507 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
32508 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
32509 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
32510 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32511 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
32512 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
32513 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
32514 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
32515 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32516 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
32517 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
32518 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
32519 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
32520 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
32521 **** ko - n - data *
32522 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
32523 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
32524 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
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 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
32528 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
32529 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
32530 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
32531 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
32532 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
32534 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
32535 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
32536 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
32537 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
32538 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
32539 **** ako - p - data *
32540 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
32541 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
32542 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
32543 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
32544 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
32545 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
32546 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
32547 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
32548 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
32549 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
32550 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
32551 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
32552 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
32553 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
32554 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
32555 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
32556 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
32557 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
32558 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
32559 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
32560 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
32561 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
32562 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
32563 *= end*block.blkdt3 *
32566 *===qel_pol============================================================*
32568 CDECK ID>, DT_QEL_POL
32569 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
32571 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32575 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
32580 C==================================================================
32581 C Generation of a Quasi-Elastic neutrino scattering
32582 C==================================================================
32584 *===gen_qel============================================================*
32586 CDECK ID>, DT_GEN_QEL
32587 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
32589 C...Generate a quasi-elastic neutrino/antineutrino
32590 C. Interaction on a nuclear target
32591 C. INPUT : LTYP = neutrino type (1,...,6)
32592 C. ENU (GeV) = neutrino energy
32593 C----------------------------------------------------
32595 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32598 PARAMETER ( LINP = 5 ,
32602 PARAMETER (MAXLND=4000)
32603 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
32605 * nuclear potential
32607 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
32608 & EBINDP(2),EBINDN(2),EPOT(2,210),
32609 & ETACOU(2),ICOUL,LFERMI
32610 * steering flags for qel neutrino scattering modules
32611 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
32612 **sr - removed (not needed)
32613 C COMMON /CBAD/ LBAD, NBAD
32614 C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
32617 DIMENSION PI(3),PO(3)
32622 C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
32623 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
32624 DATA AMN /0.93827231D0, 0.93956563D0/
32625 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
32628 C DATA PFERMI/0.22D0/
32629 CGB+...Binding Energy
32630 DATA EBIND/0.008D0/
32634 IF(ININU.EQ.1)NDSIG=0
32639 AML = AML0(LTYP) ! massa leptoni
32640 AML2 = AML**2 ! massa leptoni **2
32641 C...Particle labels (LUND)
32651 K0 = (LTYP-1)/2 ! 2
32653 KA = 12 + 2*K0 ! 16
32654 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
32658 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
32659 IF (LNU .EQ. 2) THEN
32687 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
32688 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
32693 C...4-momentum initial lepton
32694 P(1,5) = 0. ! massa
32695 P(1,4) = ENU0 ! energia
32700 C PF = PFERMI*PYR(0)**(1./3.)
32701 c write(23,*) PYR(0)
32702 c write(*,*) 'Pfermi=',PF
32705 C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
32706 IF (NTRY .GT. 500) THEN
32708 WRITE (LOUT,1001) NBAD, ENU
32711 C CT = -1. + 2.*PYR(0)
32713 C ST = SQRT(1.-CT*CT)
32714 C F = 2.*3.1415926*PYR(0)
32717 C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
32718 C P(2,1) = PF*ST*COS(F) ! px
32719 C P(2,2) = PF*ST*SIN(F) ! py
32720 C P(2,3) = PF*CT ! pz
32721 C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
32727 beta1=-p(2,1)/p(2,4)
32728 beta2=-p(2,2)/p(2,4)
32729 beta3=-p(2,3)/p(2,4)
32731 C WRITE(6,*)' before transforming into target rest frame'
32733 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
32735 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
32738 phi11=atan(p(1,2)/p(1,3))
32743 CALL DT_TESTROT(PI,Po,PHI11,1)
32745 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32751 phi12=atan(p(1,1)/p(1,3))
32756 CALL DT_TESTROT(Pi,Po,PHI12,2)
32758 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32767 C...Kinematical limits in Q**2
32768 c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
32769 S = P(2,5)**2 + 2.*ENU*P(2,5)
32770 SQS = SQRT(S) ! E centro massa
32771 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
32772 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
32773 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
32774 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
32775 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
32776 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
32777 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
32780 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
32781 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
32782 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
32783 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
32784 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
32786 C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
32787 C &Q2,Q2min,Q2MAX,DSIGEV
32789 C...c.m. frame. Neutrino along z axis
32790 DETOT = (P(1,4)) + (P(2,4)) ! e totale
32791 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
32792 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
32793 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
32796 C WRITE(*,*) 'Input values laboratory frame'
32799 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
32802 c STHETA = ULANGL(P(1,3),P(1,1))
32803 c write(*,*) 'stheta' ,stheta
32805 c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
32808 C WRITE(*,*) 'Output values cm frame'
32809 C...Kinematic in c.m. frame
32810 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
32811 STSTAR = SQRT(1.-CTSTAR**2)
32812 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
32813 P(4,5) = AML ! massa leptone
32814 P(4,4) = ELF ! e leptone
32815 P(4,3) = PLF*CTSTAR ! px
32816 P(4,1) = PLF*STSTAR*COS(PHI) ! py
32817 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
32819 P(5,5) = AMF ! barione
32820 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
32821 P(5,3) = -P(4,3) ! px
32822 P(5,1) = -P(4,1) ! py
32823 P(5,2) = -P(4,2) ! pz
32826 P(3,1) = P(1,1)-P(4,1)
32827 P(3,2) = P(1,2)-P(4,2)
32828 P(3,3) = P(1,3)-P(4,3)
32829 P(3,4) = P(1,4)-P(4,4)
32831 C...Transform back to laboratory frame
32832 C WRITE(*,*) 'before going back to nucl rest frame'
32833 c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
32836 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
32838 C WRITE(*,*) 'Now back in nucl rest frame'
32839 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
32841 c********************************************
32847 CALL DT_TESTROT(Pi,Po,PHI12,3)
32849 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32855 c********************************************
32861 CALL DT_TESTROT(Pi,Po,PHI11,4)
32863 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32870 c********************************************
32872 C WRITE(*,*) 'Now back in lab frame'
32874 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
32877 C...test (on final momentum of nucleon) if Fermi-blocking
32879 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
32881 IF (ENUCL.LT. EFMAX) THEN
32882 IF(INIPRI.LT.10)THEN
32884 C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
32885 C...the interaction is not possible due to Pauli-Blocking and
32886 C...it must be resampled
32889 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
32890 IF(INIPRI.LT.10)THEN
32892 C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
32894 C Reject (J:R) here all these events
32895 C are otherwise rejected in dpmjet
32897 C...the interaction is possible, but the nucleon remains inside
32898 C...the nucleus. The nucleus is therefore left excited.
32899 C...We treat this case as a nucleon with 0 kinetic energy.
32905 ELSE IF (ENUCL.GE.ENWELL) THEN
32906 C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
32907 C...the interaction is possible, the nucleon can exit the nucleus
32908 C...but the nuclear well depth must be subtracted. The nucleus could be
32909 C...left in an excited state.
32910 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
32911 C P(5,4) = ENUCL-ENWELL + AMF
32912 Pnucl = SQRT(P(5,4)**2-AMF**2)
32913 C...The 3-momentum is scaled assuming that the direction remains
32915 P(5,1) = P(5,1) * Pnucl/Pstart
32916 P(5,2) = P(5,2) * Pnucl/Pstart
32917 P(5,3) = P(5,3) * Pnucl/Pstart
32918 C WRITE(6,*)' qel new P(5,4) ',P(5,4)
32921 DSIGSU=DSIGSU+DSIGEV
32931 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
32933 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
32937 C PRINT*,' FINE EVENTO '
32941 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
32944 C====================================================================
32946 C====================================================================
32949 *===mass_ini===========================================================*
32951 CDECK ID>, DT_MASS_INI
32952 SUBROUTINE DT_MASS_INI
32953 C...Initialize the kinematics for the quasi-elastic cross section
32955 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32958 * particle masses used in qel neutrino scattering modules
32959 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
32960 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
32961 & EMPROTSQ,EMNEUTSQ,EMNSQ
32963 EML(1) = 0.51100D-03 ! e-
32964 EML(2) = EML(1) ! e+
32965 EML(3) = 0.105659D0 ! mu-
32966 EML(4) = EML(3) ! mu+
32967 EML(5) = 1.7777D0 ! tau-
32968 EML(6) = EML(5) ! tau+
32969 EMPROT = 0.93827231D0 ! p
32970 EMNEUT = 0.93956563D0 ! n
32971 EMPROTSQ = EMPROT**2
32972 EMNEUTSQ = EMNEUT**2
32973 EMN = (EMPROT + EMNEUT)/2.
32977 EMN1(J0+1) = EMNEUT
32978 EMN1(J0+2) = EMPROT
32979 EMN2(J0+1) = EMPROT
32980 EMN2(J0+2) = EMNEUT
32983 EMLSQ(J) = EML(J)**2
32984 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
32989 *===dsqel_q2===========================================================*
32991 CDECK ID>, DT_DSQEL_Q2
32992 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
32994 C...differential cross section for Quasi-Elastic scattering
32995 C. nu + N -> l + N'
32996 C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
32998 C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
32999 C. ENU (GeV) = Neutrino energy
33000 C. Q2 (GeV**2) = (Transfer momentum)**2
33002 C. OUTPUT : DSQEL_Q2 = differential cross section :
33003 C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
33004 C------------------------------------------------------------------
33006 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33009 * particle masses used in qel neutrino scattering modules
33010 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
33011 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
33012 & EMPROTSQ,EMNEUTSQ,EMNSQ
33013 **sr - removed (not needed)
33014 C COMMON /CAXIAL/ FA0, AXIAL2
33018 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
33019 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
33020 DATA AXIAL2 /1.03D0/ ! to be checked
33024 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
33025 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
33026 X = Q2/(EMN*EMN) ! emn=massa barione
33028 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
33029 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
33030 FA = FA0/(1.D0 + Q2/AXIAL2)**2
33034 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
33035 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
33036 A2 = -RM * ((FV1 + FV2)**2 + FFA)
33037 AA = (XA+0.25D0*RM)*(A1 + A2)
33038 BB = -X*FA*(FV1 + FV2)
33039 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
33040 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
33041 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
33042 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
33047 *===prepola============================================================*
33049 CDECK ID>, DT_PREPOLA
33050 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
33052 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33055 c By G. Battistoni and E. Scapparone (sept. 1997)
33057 c Albright & Jarlskog, Nucl Phys B84 (1975) 467
33061 PARAMETER (MAXLND=4000)
33062 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
33064 COMMON /QNPOL/ POLARX(4),PMODUL
33065 * particle masses used in qel neutrino scattering modules
33066 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
33067 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
33068 & EMPROTSQ,EMNEUTSQ,EMNSQ
33069 * steering flags for qel neutrino scattering modules
33070 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
33071 **sr - removed (not needed)
33072 C COMMON /CAXIAL/ FA0, AXIAL2
33073 C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
33074 C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
33076 REAL*8 POL(4,4),BB2(3)
33078 C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
33079 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
33080 **sr uncommented since common block CAXIAL is now commented
33081 DATA AXIAL2 /1.03D0/ ! to be checked
33091 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
33092 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
33093 X = Q2/(EMN*EMN) ! emn=massa barione
33095 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
33096 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
33097 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
33101 FP=2.D0*FA*RMM/(MPI**2 + Q2)
33102 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
33103 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
33104 A2 = -RM * ((FV1 + FV2)**2 + FFA)
33105 AA = (XA+0.25D+00*RM)*(A1 + A2)
33106 BB = -X*FA*(FV1 + FV2)
33107 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
33108 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
33110 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
33112 OMEGA3=2.D+00*FA*(FV1+FV2)
33113 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
33116 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
33117 WW1=2.D+00*OMEGA1*EMN**2
33118 WW2=2.D+00*OMEGA2*EMN**2
33119 WW3=2.D+00*OMEGA3*EMN**2
33120 WW4=2.D+00*OMEGA4*EMN**2
33121 WW5=2.D+00*OMEGA5*EMN**2
33124 BB2(I)=-P(4,I)/P(4,4)
33128 c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
33131 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
33133 * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
33136 c WRITE(*,*) 'Prepola: now in lepton rest frame'
33140 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
33141 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
33142 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
33144 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
33145 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
33147 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
33150 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
33156 PMODUL=PMODUL+POL(4,I)**2
33159 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
33160 IF(NEUDEC.EQ.1) THEN
33161 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
33163 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33165 c Tau has decayed in muon
33168 IF(NEUDEC.EQ.2) THEN
33169 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
33171 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33173 c Tau has decayed in electron
33181 c fill common for muon(electron)
33189 IF(NEUDEC.EQ.1) THEN
33192 ELSEIF(NEUDEC.EQ.2) THEN
33196 ELSEIF(JTYP.EQ.6) THEN
33197 IF(NEUDEC.EQ.1) THEN
33199 ELSEIF(NEUDEC.EQ.2) THEN
33207 c fill common for tau_(anti)neutrino
33217 ELSEIF(JTYP.EQ.6) THEN
33224 c Fill common for muon(electron)_(anti)neutrino
33233 IF(NEUDEC.EQ.1) THEN
33235 ELSEIF(NEUDEC.EQ.2) THEN
33238 ELSEIF(JTYP.EQ.6) THEN
33239 IF(NEUDEC.EQ.1) THEN
33241 ELSEIF(NEUDEC.EQ.2) THEN
33252 c IF(PMODUL.GE.1.D+00) THEN
33253 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
33254 c write(*,*) pmodul
33256 c POL(4,I)=POL(4,I)/PMODUL
33257 c POLARX(I)=POL(4,I)
33261 c PMODUL=PMODUL+POL(4,I)**2
33263 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
33267 c WRITE(*,*) 'PMODUL = ',PMODUL
33271 c WRITE(*,*) 'prepola: Now back to nucl rest frame'
33273 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
33275 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
33276 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
33277 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
33287 *===testrot============================================================*
33289 CDECK ID>, DT_TESTROT
33290 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
33292 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33295 DIMENSION ROT(3,3),PI(3),PO(3)
33297 IF (MODE.EQ.1) THEN
33302 ROT(2,2) = COS(PHI)
33303 ROT(2,3) = -SIN(PHI)
33305 ROT(3,2) = SIN(PHI)
33306 ROT(3,3) = COS(PHI)
33307 ELSEIF (MODE.EQ.2) THEN
33311 ROT(2,1) = COS(PHI)
33313 ROT(2,3) = -SIN(PHI)
33314 ROT(3,1) = SIN(PHI)
33316 ROT(3,3) = COS(PHI)
33317 ELSEIF (MODE.EQ.3) THEN
33321 ROT(1,2) = COS(PHI)
33323 ROT(3,2) = -SIN(PHI)
33324 ROT(1,3) = SIN(PHI)
33326 ROT(3,3) = COS(PHI)
33327 ELSEIF (MODE.EQ.4) THEN
33332 ROT(2,2) = COS(PHI)
33333 ROT(3,2) = -SIN(PHI)
33335 ROT(2,3) = SIN(PHI)
33336 ROT(3,3) = COS(PHI)
33338 STOP ' TESTROT: mode not supported!'
33341 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
33347 *===lepdcyp============================================================*
33349 CDECK ID>, DT_LEPDCYP
33350 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
33351 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33353 C-----------------------------------------------------------------
33355 C Author :- G. Battistoni 10-NOV-1995
33357 C=================================================================
33359 C Purpose : performs decay of polarized lepton in
33360 C its rest frame: a => b + l + anti-nu
33361 C (Example: mu- => nu-mu + e- + anti-nu-e)
33362 C Polarization is assumed along Z-axis
33364 C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
33365 C OF NEGLIGIBLE MASS
33366 C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
33369 C Method : modifies phase space distribution obtained
33370 C by routine EXPLOD using a rejection against the
33371 C matrix element for unpolarized lepton decay
33373 C Inputs : Mass of a : AMA
33376 C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
33379 C Outputs : kinematic variables in the rest frame of decaying lepton
33380 C ETL,PXL,PYL,PZL 4-moment of l
33381 C ETB,PXB,PYB,PZB 4-moment of b
33382 C ETN,PXN,PYN,PZN 4-moment of anti-nu
33384 C============================================================
33388 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33391 PARAMETER ( LINP = 5 ,
33395 PARAMETER ( KALGNM = 2 )
33396 PARAMETER ( ANGLGB = 5.0D-16 )
33397 PARAMETER ( ANGLSQ = 2.5D-31 )
33398 PARAMETER ( AXCSSV = 0.2D+16 )
33399 PARAMETER ( ANDRFL = 1.0D-38 )
33400 PARAMETER ( AVRFLW = 1.0D+38 )
33401 PARAMETER ( AINFNT = 1.0D+30 )
33402 PARAMETER ( AZRZRZ = 1.0D-30 )
33403 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
33404 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
33405 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
33406 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
33407 PARAMETER ( CSNNRM = 2.0D-15 )
33408 PARAMETER ( DMXTRN = 1.0D+08 )
33409 PARAMETER ( ZERZER = 0.D+00 )
33410 PARAMETER ( ONEONE = 1.D+00 )
33411 PARAMETER ( TWOTWO = 2.D+00 )
33412 PARAMETER ( THRTHR = 3.D+00 )
33413 PARAMETER ( FOUFOU = 4.D+00 )
33414 PARAMETER ( FIVFIV = 5.D+00 )
33415 PARAMETER ( SIXSIX = 6.D+00 )
33416 PARAMETER ( SEVSEV = 7.D+00 )
33417 PARAMETER ( EIGEIG = 8.D+00 )
33418 PARAMETER ( ANINEN = 9.D+00 )
33419 PARAMETER ( TENTEN = 10.D+00 )
33420 PARAMETER ( HLFHLF = 0.5D+00 )
33421 PARAMETER ( ONETHI = ONEONE / THRTHR )
33422 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
33423 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
33424 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
33425 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
33426 PARAMETER ( CLIGHT = 2.99792458 D+10 )
33427 PARAMETER ( AVOGAD = 6.0221367 D+23 )
33428 PARAMETER ( AMELGR = 9.1093897 D-28 )
33429 PARAMETER ( PLCKBR = 1.05457266 D-27 )
33430 PARAMETER ( ELCCGS = 4.8032068 D-10 )
33431 PARAMETER ( ELCMKS = 1.60217733 D-19 )
33432 PARAMETER ( AMUGRM = 1.6605402 D-24 )
33433 PARAMETER ( AMMUMU = 0.113428913 D+00 )
33434 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
33435 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
33436 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
33437 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
33438 PARAMETER ( PLABRC = 0.197327053 D+00 )
33439 PARAMETER ( AMELCT = 0.51099906 D-03 )
33440 PARAMETER ( AMUGEV = 0.93149432 D+00 )
33441 PARAMETER ( AMMUON = 0.105658389 D+00 )
33442 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
33443 PARAMETER ( GEVMEV = 1.0 D+03 )
33444 PARAMETER ( EMVGEV = 1.0 D-03 )
33445 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
33446 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
33447 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
33449 C variables for EXPLOD
33451 PARAMETER ( KPMX = 10 )
33452 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
33453 & PZEXPL (KPMX), ETEXPL (KPMX)
33457 **sr - removed (not needed)
33458 C COMMON /GBATNU/ ELERAT,NTRY
33461 C Initializes test variables
33466 C Maximum value for matrix element
33468 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
33469 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
33470 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
33471 C Inputs for EXPLOD
33472 C part. no. 1 is l (e- in mu- decay)
33473 C part. no. 2 is b (nu-mu in mu- decay)
33474 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
33475 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
33482 C phase space distribution
33487 CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
33491 C Calculates matrix element:
33492 C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
33493 C Here CTH is the cosine of the angle between anti-nu and Z axis
33495 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
33497 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
33498 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
33499 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
33500 ELEMAT = 16.D+00 * PROD1 * PROD2
33501 IF(ELEMAT.GT.ELEMAX) THEN
33502 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
33506 C Here performs the rejection
33508 TEST = DT_RNDM(ETOTEX) * ELEMAX
33509 IF ( TEST .GT. ELEMAT ) GO TO 100
33511 C final assignment of variables
33513 ELERAT = ELEMAT/ELEMAX
33529 C==================================================================
33530 C. Generation of Delta resonance events
33531 C==================================================================
33533 *===gen_delta==========================================================*
33535 CDECK ID>, DT_GEN_DELTA
33536 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
33538 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33541 PARAMETER ( LINP = 5 ,
33545 C...Generate a Delta-production neutrino/antineutrino
33546 C. CC-interaction on a nucleon
33548 C. INPUT ENU (GeV) = Neutrino Energy
33549 C. LLEP = neutrino type
33550 C. LTARG = nucleon target type 1=p, 2=n.
33551 C. JINT = 1:CC, 2::NC
33553 C. OUTPUT PPL(4) 4-monentum of final lepton
33554 C----------------------------------------------------
33556 PARAMETER (MAXLND=4000)
33557 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
33559 **sr - removed (not needed)
33560 C COMMON /CBAD/ LBAD, NBAD
33563 DIMENSION PI(3),PO(3)
33564 C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
33565 DIMENSION AML0(6),AMN(2)
33566 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
33567 DATA AMN /0.93827231, 0.93956563/
33568 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
33570 c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
33572 C...Final lepton mass
33573 IF (JINT.EQ.1) THEN
33580 C...Particle labels (LUND)
33588 IF (LTARG .EQ. 1) THEN
33596 IS = -1 + 2*LLEP - 4*K1
33597 LNU = 2 - LLEP + 2*K1
33601 IF (JINT .EQ. 1) THEN ! CC interactions
33605 IF (LTARG .EQ. 1) THEN
33611 IF (LTARG .EQ. 1) THEN
33618 K(3,2) = 23 ! NC (Z0) interactions
33620 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
33621 * Delta0 for neutron (LTARG=2)
33622 C IF (LTARG .EQ. 1) THEN
33627 IF (LTARG .EQ. 1) THEN
33635 C...4-momentum initial lepton
33641 C...4-momentum initial nucleon
33642 P(2,5) = AMN(LTARG)
33653 beta1=-p(2,1)/p(2,4)
33654 beta2=-p(2,2)/p(2,4)
33655 beta3=-p(2,3)/p(2,4)
33658 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
33660 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
33662 phi11=atan(p(1,2)/p(1,3))
33667 CALL DT_TESTROT(PI,Po,PHI11,1)
33669 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33674 phi12=atan(p(1,1)/p(1,3))
33679 CALL DT_TESTROT(Pi,Po,PHI12,2)
33681 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33689 C...Generate the Mass of the Delta
33692 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
33694 IF (NTRY .GT. 1000) THEN
33696 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
33699 IF (AMD .LT. AMDMIN) GOTO 100
33700 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
33701 IF (ENUU .LT. ET) GOTO 100
33703 C...Kinematical limits in Q**2
33704 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
33706 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
33707 ELF = (S - AMD**2 + AML2)/(2.*SQS)
33708 PLF = SQRT(ELF**2 - AML2)
33709 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
33710 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
33711 IF (Q2MIN .LT. 0.) Q2MIN = 0.
33713 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
33714 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
33715 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
33716 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
33718 C...Generate the kinematics of the final particles
33719 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
33720 GAM = EISTAR/AMN(LTARG)
33722 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
33723 EL = GAM*(ELF + BET*PLF*CTSTAR)
33724 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
33725 PL = SQRT(EL**2 - AML2)
33726 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
33727 PHI = 6.28319*PYR(0)
33728 P(4,1) = PLT*COS(PHI)
33729 P(4,2) = PLT*SIN(PHI)
33734 C...4-momentum of Delta
33737 P(5,3) = ENUU-P(4,3)
33738 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
33741 C...4-momentum of intermediate boson
33743 P(3,4) = P(1,4)-P(4,4)
33744 P(3,1) = P(1,1)-P(4,1)
33745 P(3,2) = P(1,2)-P(4,2)
33746 P(3,3) = P(1,3)-P(4,3)
33753 CALL DT_TESTROT(Pi,Po,PHI12,3)
33755 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33762 c********************************************
33768 CALL DT_TESTROT(Pi,Po,PHI11,4)
33770 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33776 c********************************************
33777 C transform back into Lab.
33779 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
33781 C WRITE(6,*)' Lab fram ( fermi incl.) '
33786 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
33789 *===dsigma_delta=======================================================*
33791 CDECK ID>, DT_DSIGMA_DELTA
33792 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
33794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33797 C...Reaction nu + N -> lepton + Delta
33798 C. returns the cross section
33800 C. INPUT LNU = 1, 2 (neutrino-antineutrino)
33801 C. QQ = t (always negative) GeV**2
33802 C. S = (c.m energy)**2 GeV**2
33803 C. OUTPUT = 10**-38 cm+2/GeV**2
33804 C-----------------------------------------------------
33805 REAL*8 MN, MN2, MN4, MD,MD2, MD4
33807 DATA PI /3.1415926/
33809 GF = (1.1664 * 1.97)
33817 VQ = (MN2 - MD2 - QQ)/2.
33818 VPI = (MN2 + MD2 - QQ)/2.
33819 VK = (S + QQ - MN2 - AML2)/2.
33821 QK = (AML2 - QQ)/2.
33822 PIQ = (QQ + MN2 - MD2)/2.
33824 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
33825 C3 = SQRT(3.)*C3V/MN
33826 C4 = -C3/MD ! attenzione al segno
33827 C5A = 1.18/(1.-QQ/0.4225)**2
33832 IF (LNU .EQ. 1) THEN
33833 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
33834 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
33835 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
33836 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
33837 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
33838 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
33839 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
33840 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
33841 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
33842 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
33843 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
33844 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
33845 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
33846 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
33847 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
33848 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
33849 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
33850 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
33851 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
33852 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
33853 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
33854 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
33855 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
33857 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
33858 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
33859 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
33860 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
33861 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
33862 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
33863 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
33864 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
33865 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
33866 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
33867 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
33868 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
33869 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
33870 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
33871 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
33872 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
33873 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
33874 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
33875 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
33876 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
33877 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
33878 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
33879 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
33883 P1CM = (S-MN2)/(2.*SQRT(S))
33884 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
33889 *===qgaus==============================================================*
33891 CDECK ID>, DT_QGAUS
33892 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
33894 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33897 DIMENSION X(5),W(5)
33898 DATA X/.1488743389D0,.4333953941D0,
33899 & .6794095682D0,.8650633666D0,.9739065285D0
33901 DATA W/.2955242247D0,.2692667193D0,
33902 & .2190863625D0,.1494513491D0,.0666713443D0
33909 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
33910 * DT_DSQEL_Q2(LTYP,ENU,XM-DX))
33917 *===diqbrk=============================================================*
33919 CDECK ID>, DT_DIQBRK
33920 SUBROUTINE DT_DIQBRK
33922 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33927 PARAMETER (NMXHKK=200000)
33929 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
33930 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
33931 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
33932 * extended event history
33933 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
33934 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
33937 COMMON /DTEVNO/ NEVENT,ICASCA
33939 C IF(DT_RNDM(VV).LE.0.5D0)THEN
33940 C CALL GSQBS1(NHKK)
33941 C CALL GSQBS2(NHKK)
33942 C CALL USQBS1(NHKK)
33943 C CALL USQBS2(NHKK)
33944 C CALL GSABS1(NHKK)
33945 C CALL GSABS2(NHKK)
33946 C CALL USABS1(NHKK)
33947 C CALL USABS2(NHKK)
33949 C CALL GSQBS2(NHKK)
33950 C CALL GSQBS1(NHKK)
33951 C CALL USQBS2(NHKK)
33952 C CALL USQBS1(NHKK)
33953 C CALL GSABS2(NHKK)
33954 C CALL GSABS1(NHKK)
33955 C CALL USABS2(NHKK)
33956 C CALL USABS1(NHKK)
33959 IF(DT_RNDM(VV).LE.0.5D0) THEN
33983 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
33984 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
33985 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
33987 C USQBS-2 diagram (split target diquark)
33989 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33992 PARAMETER ( LINP = 5 ,
33998 PARAMETER (NMXHKK=200000)
34000 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
34001 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
34002 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
34003 * extended event history
34004 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
34005 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
34007 * Lorentz-parameters of the current interaction
34008 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
34009 & UMO,PPCM,EPROJ,PPROJ
34010 * diquark-breaking mechanism
34011 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
34014 PARAMETER (NTMHKK= 300)
34015 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34016 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34019 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
34022 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
34023 COMMON /EVFLAG/ NUMEV
34025 C USQBS-2 diagram (split target diquark)
34028 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
34029 C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
34031 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
34032 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34034 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34035 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34036 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34039 C Put new chains into COMMON /HKKTMP/
34044 C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
34048 C IF(NUMEV.EQ.-324)THEN
34049 C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
34050 C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
34051 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34052 C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
34057 C determine x-values of NC1T diquark
34058 XDIQT=PHKK(4,NC1T)*2.D0/UMO
34059 XVQP=PHKK(4,NC1P)*2.D0/UMO
34061 C determine x-values of sea quark pair
34067 IF(ICOU.GE.500)THEN
34070 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
34074 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
34079 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
34080 IF (IPIP.EQ.1) THEN
34081 XQMAX = XDIQT/2.0D0
34082 XAQMAX = 2.D0*XVQP/3.0D0
34084 XQMAX = 2.D0*XVQP/3.0D0
34085 XAQMAX = XDIQT/2.0D0
34087 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
34089 C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
34092 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34095 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34100 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34101 ELSEIF(IPIP.EQ.2)THEN
34102 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34105 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
34106 * XDIQT,XVQP,XSQ,XSAQ
34109 C subtract xsq,xsaq from NC1T diquark and NC1P quark
34115 ELSEIF(IPIP.EQ.2)THEN
34120 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
34122 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34127 IF(IVTHR.EQ.10)THEN
34130 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
34135 XVTHR=XVTHRO/(201-IVTHR)
34138 IF(XVTHR.GT.0.66D0*XDIQT)THEN
34141 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ',
34146 IF(DT_RNDM(V).LT.0.5D0)THEN
34147 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34150 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34154 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
34157 C Prepare 4 momenta of new chains and chain ends
34159 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34160 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34163 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34164 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34165 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34167 C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34168 C * IP1,IP21,IP22,IPP1,IPP2)
34175 ELSEIF(IPIP.EQ.2)THEN
34185 JDAHKT(1,1)=3+IIGLU1
34187 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34188 PHKT(1,1) =PHKK(1,NC2P)
34189 PHKT(2,1) =PHKK(2,NC2P)
34190 PHKT(3,1) =PHKK(3,NC2P)
34191 PHKT(4,1) =PHKK(4,NC2P)
34192 C PHKT(5,1) =PHKK(5,NC2P)
34193 XMIST =(PHKT(4,1)**2-
34194 * PHKT(3,1)**2-PHKT(2,1)**2-
34196 IF(XMIST.GT.0.D0)THEN
34197 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
34200 C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
34203 VHKT(1,1) =VHKK(1,NC2P)
34204 VHKT(2,1) =VHKK(2,NC2P)
34205 VHKT(3,1) =VHKK(3,NC2P)
34206 VHKT(4,1) =VHKK(4,NC2P)
34207 WHKT(1,1) =WHKK(1,NC2P)
34208 WHKT(2,1) =WHKK(2,NC2P)
34209 WHKT(3,1) =WHKK(3,NC2P)
34210 WHKT(4,1) =WHKK(4,NC2P)
34211 C Add here IIGLU1 gluons to this chaina
34216 IF(IIGLU1.GE.1)THEN
34218 DO 61 IIG=2,2+IIGLU1-1
34220 IDHKT(IIG) =IDHKK(KKG)
34224 JDAHKT(1,IIG)=3+IIGLU1
34226 PHKT(1,IIG)=PHKK(1,KKG)
34227 PG1=PG1+ PHKT(1,IIG)
34228 PHKT(2,IIG)=PHKK(2,KKG)
34229 PG2=PG2+ PHKT(2,IIG)
34230 PHKT(3,IIG)=PHKK(3,KKG)
34231 PG3=PG3+ PHKT(3,IIG)
34232 PHKT(4,IIG)=PHKK(4,KKG)
34233 PG4=PG4+ PHKT(4,IIG)
34234 PHKT(5,IIG)=PHKK(5,KKG)
34235 VHKT(1,IIG) =VHKK(1,KKG)
34236 VHKT(2,IIG) =VHKK(2,KKG)
34237 VHKT(3,IIG) =VHKK(3,KKG)
34238 VHKT(4,IIG) =VHKK(4,KKG)
34239 WHKT(1,IIG) =WHKK(1,KKG)
34240 WHKT(2,IIG) =WHKK(2,KKG)
34241 WHKT(3,IIG) =WHKK(3,KKG)
34242 WHKT(4,IIG) =WHKK(4,KKG)
34245 IDHKT(2+IIGLU1) =IP21
34246 ISTHKT(2+IIGLU1) =952
34247 JMOHKT(1,2+IIGLU1)=NC1T
34248 JMOHKT(2,2+IIGLU1)=0
34249 JDAHKT(1,2+IIGLU1)=3+IIGLU1
34250 JDAHKT(2,2+IIGLU1)=0
34251 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
34252 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
34253 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
34254 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
34255 C PHKT(5,2) =PHKK(5,NC1T)
34256 XMIST =(PHKT(4,2+IIGLU1)**2-
34257 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
34258 *PHKT(1,2+IIGLU1)**2)
34259 IF(XMIST.GT.0.D0)THEN
34260 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
34261 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
34262 *PHKT(1,2+IIGLU1)**2)
34264 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
34265 PHKT(5,5+IIGLU1)=0.D0
34267 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
34268 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
34269 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
34270 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
34271 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
34272 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
34273 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
34274 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
34275 IDHKT(3+IIGLU1) =88888
34276 ISTHKT(3+IIGLU1) =95
34277 JMOHKT(1,3+IIGLU1)=1
34278 JMOHKT(2,3+IIGLU1)=2+IIGLU1
34279 JDAHKT(1,3+IIGLU1)=0
34280 JDAHKT(2,3+IIGLU1)=0
34281 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
34282 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
34283 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
34284 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
34286 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
34287 * -PHKT(3,3+IIGLU1)**2)
34288 IF(XMIST.GT.0.D0)THEN
34290 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
34291 * -PHKT(3,3+IIGLU1)**2)
34293 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
34294 PHKT(5,5+IIGLU1)=0.D0
34297 C IF(NUMEV.EQ.-324)THEN
34298 C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
34300 C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
34301 DO 71 IIG=2,2+IIGLU1-1
34302 C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
34303 C & JMOHKT(1,IIG),JMOHKT(2,IIG),
34305 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
34307 C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
34308 C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
34309 C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
34310 C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
34311 C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
34312 C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
34316 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
34317 ELSEIF(IPIP.EQ.2)THEN
34318 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
34320 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
34324 C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
34327 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
34328 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
34329 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
34330 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
34331 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
34332 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
34333 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
34334 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
34336 IDHKT(4+IIGLU1) =-(ISAQ1-6)
34337 ELSEIF(IPIP.EQ.2)THEN
34338 IDHKT(4+IIGLU1) =ISAQ1
34340 ISTHKT(4+IIGLU1) =951
34341 JMOHKT(1,4+IIGLU1)=NC1P
34342 JMOHKT(2,4+IIGLU1)=0
34343 JDAHKT(1,4+IIGLU1)=6+IIGLU1
34344 JDAHKT(2,4+IIGLU1)=0
34345 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34346 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
34347 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
34348 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
34349 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
34350 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
34351 XMIST =(PHKT(4,4+IIGLU1)**2-
34352 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
34353 *PHKT(1,4+IIGLU1)**2)
34354 IF(XMIST.GT.0.D0)THEN
34355 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
34356 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
34357 *PHKT(1,4+IIGLU1)**2)
34359 C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
34360 PHKT(5,4+IIGLU1)=0.D0
34362 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
34363 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
34364 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
34365 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
34366 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
34367 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
34368 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
34369 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
34370 IDHKT(5+IIGLU1) =IP22
34371 ISTHKT(5+IIGLU1) =952
34372 JMOHKT(1,5+IIGLU1)=NC1T
34373 JMOHKT(2,5+IIGLU1)=0
34374 JDAHKT(1,5+IIGLU1)=6+IIGLU1
34375 JDAHKT(2,5+IIGLU1)=0
34376 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
34377 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
34378 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
34379 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
34380 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
34381 XMIST =(PHKT(4,5+IIGLU1)**2-
34382 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
34383 *PHKT(1,5+IIGLU1)**2)
34384 IF(XMIST.GT.0.D0)THEN
34385 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
34386 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
34387 *PHKT(1,5+IIGLU1)**2)
34389 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34390 PHKT(5,5+IIGLU1)=0.D0
34392 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
34393 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
34394 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
34395 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
34396 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
34397 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
34398 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
34399 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
34400 IDHKT(6+IIGLU1) =88888
34401 ISTHKT(6+IIGLU1) =95
34402 JMOHKT(1,6+IIGLU1)=4+IIGLU1
34403 JMOHKT(2,6+IIGLU1)=5+IIGLU1
34404 JDAHKT(1,6+IIGLU1)=0
34405 JDAHKT(2,6+IIGLU1)=0
34406 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
34407 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
34408 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
34409 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
34411 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34412 * -PHKT(3,6+IIGLU1)**2)
34413 IF(XMIST.GT.0.D0)THEN
34415 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34416 * -PHKT(3,6+IIGLU1)**2)
34418 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34419 PHKT(5,5+IIGLU1)=0.D0
34421 C IF(IPIP.GE.2)THEN
34422 C IF(NUMEV.EQ.-324)THEN
34423 C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
34424 C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
34425 C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
34426 C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
34427 C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
34428 C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
34429 C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
34430 C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
34431 C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
34435 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
34436 ELSEIF(IPIP.EQ.2)THEN
34437 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
34439 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
34443 C WRITE(6,*)' MUSQBS1 jump back from chain 6',
34444 C * CHAMAL,PHKT(5,6+IIGLU1)
34447 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
34448 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
34449 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
34450 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
34451 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
34452 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
34453 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
34454 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
34455 C IDHKT(7) =1000*IPP1+100*ISQ+1
34456 IDHKT(7+IIGLU1) =IP1
34457 ISTHKT(7+IIGLU1) =951
34458 JMOHKT(1,7+IIGLU1)=NC1P
34459 JMOHKT(2,7+IIGLU1)=0
34461 C JDAHKT(1,7+IIGLU1)=9+IIGLU1
34462 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
34464 JDAHKT(2,7+IIGLU1)=0
34465 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
34466 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
34467 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
34468 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
34469 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
34470 XMIST =(PHKT(4,7+IIGLU1)**2-
34471 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
34472 *PHKT(1,7+IIGLU1)**2)
34473 IF(XMIST.GT.0.D0)THEN
34474 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
34475 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
34476 *PHKT(1,7+IIGLU1)**2)
34478 C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
34479 PHKT(5,7+IIGLU1)=0.D0
34481 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
34482 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
34483 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
34484 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
34485 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
34486 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
34487 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
34488 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
34489 C Insert here the IIGLU2 gluons
34494 IF(IIGLU2.GE.1)THEN
34496 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
34497 KKG=JJG+IIG-7-IIGLU1
34498 IDHKT(IIG) =IDHKK(KKG)
34502 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
34504 PHKT(1,IIG)=PHKK(1,KKG)
34505 PG1=PG1+ PHKT(1,IIG)
34506 PHKT(2,IIG)=PHKK(2,KKG)
34507 PG2=PG2+ PHKT(2,IIG)
34508 PHKT(3,IIG)=PHKK(3,KKG)
34509 PG3=PG3+ PHKT(3,IIG)
34510 PHKT(4,IIG)=PHKK(4,KKG)
34511 PG4=PG4+ PHKT(4,IIG)
34512 PHKT(5,IIG)=PHKK(5,KKG)
34513 VHKT(1,IIG) =VHKK(1,KKG)
34514 VHKT(2,IIG) =VHKK(2,KKG)
34515 VHKT(3,IIG) =VHKK(3,KKG)
34516 VHKT(4,IIG) =VHKK(4,KKG)
34517 WHKT(1,IIG) =WHKK(1,KKG)
34518 WHKT(2,IIG) =WHKK(2,KKG)
34519 WHKT(3,IIG) =WHKK(3,KKG)
34520 WHKT(4,IIG) =WHKK(4,KKG)
34524 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
34525 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
34526 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
34527 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
34528 ELSEIF(IPIP.EQ.2)THEN
34529 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
34530 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
34531 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
34532 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
34534 ISTHKT(8+IIGLU1+IIGLU2) =952
34535 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
34536 JMOHKT(2,8+IIGLU1+IIGLU2)=0
34537 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
34538 JDAHKT(2,8+IIGLU1+IIGLU2)=0
34539 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
34540 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
34541 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
34542 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
34543 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
34544 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
34545 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
34546 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
34547 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
34548 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
34549 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
34551 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
34552 C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
34557 C PHKT(5,8) =PHKK(5,NC2T)
34558 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
34559 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
34560 *PHKT(1,8+IIGLU1+IIGLU2)**2)
34561 IF(XMIST.GT.0.D0)THEN
34562 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
34563 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
34564 *PHKT(1,8+IIGLU1+IIGLU2)**2)
34566 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34567 PHKT(5,5+IIGLU1)=0.D0
34569 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
34570 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
34571 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
34572 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
34573 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
34574 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
34575 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
34576 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
34577 IDHKT(9+IIGLU1+IIGLU2) =88888
34578 ISTHKT(9+IIGLU1+IIGLU2) =95
34579 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
34580 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
34581 JDAHKT(1,9+IIGLU1+IIGLU2)=0
34582 JDAHKT(2,9+IIGLU1+IIGLU2)=0
34584 C PHKT(1,9+IIGLU1+IIGLU2)
34585 C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
34586 C PHKT(2,9+IIGLU1+IIGLU2)
34587 C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
34588 C PHKT(3,9+IIGLU1+IIGLU2)
34589 C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
34590 C PHKT(4,9+IIGLU1+IIGLU2)
34591 C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
34592 PHKT(1,9+IIGLU1+IIGLU2)
34593 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
34594 PHKT(2,9+IIGLU1+IIGLU2)
34595 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
34596 PHKT(3,9+IIGLU1+IIGLU2)
34597 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
34598 PHKT(4,9+IIGLU1+IIGLU2)
34599 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
34602 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
34603 * -PHKT(2,9+IIGLU1+IIGLU2)**2
34604 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
34605 IF(XMIST.GT.0.D0)THEN
34606 PHKT(5,9+IIGLU1+IIGLU2)
34607 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
34608 * -PHKT(2,9+IIGLU1+IIGLU2)**2
34609 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
34611 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34612 PHKT(5,5+IIGLU1)=0.D0
34615 C IF(NUMEV.EQ.-324)THEN
34616 C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
34617 C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
34618 C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
34619 C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
34620 C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
34622 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
34624 C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
34625 C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
34626 C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
34627 C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
34628 C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
34629 C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
34630 C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
34631 C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
34635 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
34636 ELSEIF(IPIP.EQ.2)THEN
34637 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
34639 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
34643 C WRITE(6,*)' MUSQBS1 jump back from chain 9',
34644 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
34647 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
34648 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
34649 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
34650 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
34651 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
34652 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
34653 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
34654 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
34657 IGCOUN=9+IIGLU1+IIGLU2
34662 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
34663 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34664 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
34666 C GSQBS-2 diagram (split target diquark)
34668 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34671 PARAMETER ( LINP = 5 ,
34677 PARAMETER (NMXHKK=200000)
34679 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
34680 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
34681 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
34682 * extended event history
34683 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
34684 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
34686 * Lorentz-parameters of the current interaction
34687 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
34688 & UMO,PPCM,EPROJ,PPROJ
34689 * diquark-breaking mechanism
34690 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
34693 PARAMETER (NTMHKK= 300)
34694 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34695 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34699 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
34702 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
34704 C GSQBS-2 diagram (split target diquark)
34707 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
34708 C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
34710 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
34711 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34713 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
34714 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34715 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34719 C Put new chains into COMMON /HKKTMP/
34724 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
34727 C IF(IPIP.EQ.2)THEN
34728 C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
34729 C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
34730 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34731 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
34736 C determine x-values of NC1T diquark
34737 XDIQT=PHKK(4,NC1T)*2.D0/UMO
34738 XVQP=PHKK(4,NC1P)*2.D0/UMO
34740 C determine x-values of sea quark pair
34746 IF(ICOU.GE.500)THEN
34750 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
34755 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
34760 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
34761 IF (IPIP.EQ.1) THEN
34762 XQMAX = XDIQT/2.0D0
34763 XAQMAX = 2.D0*XVQP/3.0D0
34765 XQMAX = 2.D0*XVQP/3.0D0
34766 XAQMAX = XDIQT/2.0D0
34768 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
34770 C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
34773 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34776 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34781 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34782 ELSEIF(IPIP.EQ.2)THEN
34783 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
34786 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
34787 * XDIQT,XVQP,XSQ,XSAQ
34790 C subtract xsq,xsaq from NC1T diquark and NC1P quark
34796 ELSEIF(IPIP.EQ.2)THEN
34801 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
34803 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34808 IF(IVTHR.EQ.10)THEN
34811 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
34816 XVTHR=XVTHRO/(201-IVTHR)
34819 IF(XVTHR.GT.0.66D0*XDIQT)THEN
34822 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ',
34827 IF(DT_RNDM(V).LT.0.5D0)THEN
34828 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34831 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34835 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
34838 C Prepare 4 momenta of new chains and chain ends
34840 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34841 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34844 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
34845 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34846 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34848 C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34849 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
34856 ELSEIF(IPIP.EQ.2)THEN
34863 C IDHKT(1) =1000*IPP11+100*IPP12+1
34868 IDHKT(4+IIGLU1) =-(ISAQ1-6)
34869 ELSEIF(IPIP.EQ.2)THEN
34870 IDHKT(4+IIGLU1) =ISAQ1
34872 ISTHKT(4+IIGLU1) =961
34873 JMOHKT(1,4+IIGLU1)=NC1P
34874 JMOHKT(2,4+IIGLU1)=0
34875 JDAHKT(1,4+IIGLU1)=6+IIGLU1
34876 JDAHKT(2,4+IIGLU1)=0
34877 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34878 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
34879 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
34880 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
34881 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
34882 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
34883 XXMIST=(PHKT(4,4+IIGLU1)**2-
34884 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
34885 *PHKT(1,4+IIGLU1)**2)
34886 IF(XXMIST.GT.0.D0)THEN
34887 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
34889 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
34891 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
34893 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
34894 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
34895 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
34896 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
34897 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
34898 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
34899 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
34900 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
34901 IDHKT(5+IIGLU1) =IP22
34902 ISTHKT(5+IIGLU1) =962
34903 JMOHKT(1,5+IIGLU1)=NC1T
34904 JMOHKT(2,5+IIGLU1)=0
34905 JDAHKT(1,5+IIGLU1)=6+IIGLU1
34906 JDAHKT(2,5+IIGLU1)=0
34907 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
34908 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
34909 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
34910 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
34911 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
34912 XXMIST=(PHKT(4,5+IIGLU1)**2-
34913 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
34914 *PHKT(1,5+IIGLU1)**2)
34915 IF(XXMIST.GT.0.D0)THEN
34916 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
34918 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
34920 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
34922 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
34923 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
34924 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
34925 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
34926 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
34927 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
34928 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
34929 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
34930 IDHKT(6+IIGLU1) =88888
34931 ISTHKT(6+IIGLU1) =96
34932 JMOHKT(1,6+IIGLU1)=4+IIGLU1
34933 JMOHKT(2,6+IIGLU1)=5+IIGLU1
34934 JDAHKT(1,6+IIGLU1)=0
34935 JDAHKT(2,6+IIGLU1)=0
34936 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
34937 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
34938 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
34939 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
34941 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34942 * -PHKT(3,6+IIGLU1)**2)
34945 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
34946 ELSEIF(IPIP.EQ.2)THEN
34947 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
34949 C---------------------------------------------------
34950 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
34951 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
34952 C we drop chain 6 and give the energy to chain 3
34953 IDHKT(6+IIGLU1)=22888
34955 C WRITE(6,*)' drop chain 6 xgive=1'
34957 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
34958 C we drop chain 6 and give the energy to chain 3
34959 C and change KK11 to IDHKT(5)
34960 IDHKT(6+IIGLU1)=22888
34962 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
34963 KK11=IDHKT(5+IIGLU1)
34965 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
34966 C we drop chain 6 and give the energy to chain 3
34967 C and change KK21 to IDHKT(5+IIGLU1)
34968 C IDHKT(1) =1000*IPP11+100*IPP12+1
34969 IDHKT(6+IIGLU1)=22888
34971 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
34972 KK21=IDHKT(5+IIGLU1)
34974 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
34975 C we drop chain 6 and give the energy to chain 3
34976 C and change KK22 to IDHKT(5)
34977 C IDHKT(1) =1000*IPP11+100*IPP12+1
34978 IDHKT(6+IIGLU1)=22888
34980 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
34981 KK22=IDHKT(5+IIGLU1)
34990 C---------------------------------------------------
34992 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
34993 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
34994 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
34995 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
34996 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
34997 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
34998 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
34999 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
35000 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
35002 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
35003 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
35004 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
35005 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
35006 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
35007 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
35008 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
35009 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
35010 C IDHKT(1) =1000*IPP11+100*IPP12+1
35012 IDHKT(1) =1000*KK21+100*KK22+3
35013 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
35014 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
35015 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
35016 ELSEIF(IPIP.EQ.2)THEN
35017 IDHKT(1) =1000*KK21+100*KK22-3
35018 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
35019 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
35020 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
35025 JDAHKT(1,1)=3+IIGLU1
35027 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
35028 PHKT(1,1) =PHKK(1,NC2P)
35029 *+XGIVE*PHKT(1,4+IIGLU1)
35030 PHKT(2,1) =PHKK(2,NC2P)
35031 *+XGIVE*PHKT(2,4+IIGLU1)
35032 PHKT(3,1) =PHKK(3,NC2P)
35033 *+XGIVE*PHKT(3,4+IIGLU1)
35034 PHKT(4,1) =PHKK(4,NC2P)
35035 *+XGIVE*PHKT(4,4+IIGLU1)
35036 C PHKT(5,1) =PHKK(5,NC2P)
35037 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35039 IF(XXMIST.GT.0.D0)THEN
35040 PHKT(5,1) =SQRT(XXMIST)
35042 WRITE(LOUT,*)'MGSQBS2',XXMIST
35044 PHKT(5,1) =SQRT(XXMIST)
35046 VHKT(1,1) =VHKK(1,NC2P)
35047 VHKT(2,1) =VHKK(2,NC2P)
35048 VHKT(3,1) =VHKK(3,NC2P)
35049 VHKT(4,1) =VHKK(4,NC2P)
35050 WHKT(1,1) =WHKK(1,NC2P)
35051 WHKT(2,1) =WHKK(2,NC2P)
35052 WHKT(3,1) =WHKK(3,NC2P)
35053 WHKT(4,1) =WHKK(4,NC2P)
35054 C Add here IIGLU1 gluons to this chaina
35059 IF(IIGLU1.GE.1)THEN
35061 DO 61 IIG=2,2+IIGLU1-1
35063 IDHKT(IIG) =IDHKK(KKG)
35067 JDAHKT(1,IIG)=3+IIGLU1
35069 PHKT(1,IIG)=PHKK(1,KKG)
35070 PG1=PG1+ PHKT(1,IIG)
35071 PHKT(2,IIG)=PHKK(2,KKG)
35072 PG2=PG2+ PHKT(2,IIG)
35073 PHKT(3,IIG)=PHKK(3,KKG)
35074 PG3=PG3+ PHKT(3,IIG)
35075 PHKT(4,IIG)=PHKK(4,KKG)
35076 PG4=PG4+ PHKT(4,IIG)
35077 PHKT(5,IIG)=PHKK(5,KKG)
35078 VHKT(1,IIG) =VHKK(1,KKG)
35079 VHKT(2,IIG) =VHKK(2,KKG)
35080 VHKT(3,IIG) =VHKK(3,KKG)
35081 VHKT(4,IIG) =VHKK(4,KKG)
35082 WHKT(1,IIG) =WHKK(1,KKG)
35083 WHKT(2,IIG) =WHKK(2,KKG)
35084 WHKT(3,IIG) =WHKK(3,KKG)
35085 WHKT(4,IIG) =WHKK(4,KKG)
35089 IDHKT(2+IIGLU1) =KK11
35090 ISTHKT(2+IIGLU1) =962
35091 JMOHKT(1,2+IIGLU1)=NC1T
35092 JMOHKT(2,2+IIGLU1)=0
35093 JDAHKT(1,2+IIGLU1)=3+IIGLU1
35094 JDAHKT(2,2+IIGLU1)=0
35095 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35096 C * +0.5D0*PHKK(1,NC2T)
35097 *+XGIVE*PHKT(1,5+IIGLU1)
35098 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35099 C *+0.5D0*PHKK(2,NC2T)
35100 *+XGIVE*PHKT(2,5+IIGLU1)
35101 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35102 C *+0.5D0*PHKK(3,NC2T)
35103 *+XGIVE*PHKT(3,5+IIGLU1)
35104 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35105 C *+0.5D0*PHKK(4,NC2T)
35106 *+XGIVE*PHKT(4,5+IIGLU1)
35107 C PHKT(5,2) =PHKK(5,NC1T)
35108 XXMIST=(PHKT(4,2+IIGLU1)**2-
35109 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35110 *PHKT(1,2+IIGLU1)**2)
35111 IF(XXMIST.GT.0.D0)THEN
35112 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
35114 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
35116 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
35118 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
35119 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
35120 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
35121 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
35122 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
35123 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
35124 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
35125 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
35126 IDHKT(3+IIGLU1) =88888
35127 ISTHKT(3+IIGLU1) =96
35128 JMOHKT(1,3+IIGLU1)=1
35129 JMOHKT(2,3+IIGLU1)=2+IIGLU1
35130 JDAHKT(1,3+IIGLU1)=0
35131 JDAHKT(2,3+IIGLU1)=0
35132 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35133 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35134 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35135 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35137 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35138 * -PHKT(3,3+IIGLU1)**2)
35140 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35142 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35143 DO 71 IIG=2,2+IIGLU1-1
35144 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35145 & JMOHKT(1,IIG),JMOHKT(2,IIG),
35147 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35149 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35150 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35151 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35152 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35153 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35154 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35158 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
35159 ELSEIF(IPIP.EQ.2)THEN
35160 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
35162 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35168 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
35169 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
35170 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
35171 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
35172 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
35173 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
35174 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
35175 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
35176 C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
35177 IDHKT(7+IIGLU1) =IP1
35178 ISTHKT(7+IIGLU1) =961
35179 JMOHKT(1,7+IIGLU1)=NC1P
35180 JMOHKT(2,7+IIGLU1)=0
35181 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
35182 JDAHKT(2,7+IIGLU1)=0
35183 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
35184 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
35185 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
35186 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
35187 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
35188 XXMIST=(PHKT(4,7+IIGLU1)**2-
35189 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
35190 *PHKT(1,7+IIGLU1)**2)
35191 IF(XXMIST.GT.0.D0)THEN
35192 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
35194 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
35196 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
35198 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
35199 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
35200 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
35201 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
35202 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
35203 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
35204 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
35205 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
35206 C IDHKT(7) =1000*IPP1+100*ISQ+1
35207 C Insert here the IIGLU2 gluons
35212 IF(IIGLU2.GE.1)THEN
35214 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35215 KKG=JJG+IIG-7-IIGLU1
35216 IDHKT(IIG) =IDHKK(KKG)
35220 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
35222 PHKT(1,IIG)=PHKK(1,KKG)
35223 PG1=PG1+ PHKT(1,IIG)
35224 PHKT(2,IIG)=PHKK(2,KKG)
35225 PG2=PG2+ PHKT(2,IIG)
35226 PHKT(3,IIG)=PHKK(3,KKG)
35227 PG3=PG3+ PHKT(3,IIG)
35228 PHKT(4,IIG)=PHKK(4,KKG)
35229 PG4=PG4+ PHKT(4,IIG)
35230 PHKT(5,IIG)=PHKK(5,KKG)
35231 VHKT(1,IIG) =VHKK(1,KKG)
35232 VHKT(2,IIG) =VHKK(2,KKG)
35233 VHKT(3,IIG) =VHKK(3,KKG)
35234 VHKT(4,IIG) =VHKK(4,KKG)
35235 WHKT(1,IIG) =WHKK(1,KKG)
35236 WHKT(2,IIG) =WHKK(2,KKG)
35237 WHKT(3,IIG) =WHKK(3,KKG)
35238 WHKT(4,IIG) =WHKK(4,KKG)
35242 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
35243 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
35244 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
35245 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
35246 ELSEIF(IPIP.EQ.2)THEN
35248 C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
35249 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
35251 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
35252 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
35253 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
35255 ISTHKT(8+IIGLU1+IIGLU2) =962
35256 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
35257 JMOHKT(2,8+IIGLU1+IIGLU2)=0
35258 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
35259 JDAHKT(2,8+IIGLU1+IIGLU2)=0
35260 C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
35261 C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
35262 C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
35263 C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
35264 PHKT(1,8+IIGLU1+IIGLU2) =
35265 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
35266 PHKT(2,8+IIGLU1+IIGLU2) =
35267 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
35268 PHKT(3,8+IIGLU1+IIGLU2) =
35269 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
35270 PHKT(4,8+IIGLU1+IIGLU2) =
35271 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
35272 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
35273 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
35274 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
35276 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
35281 C PHKT(5,8) =PHKK(5,NC2T)
35282 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
35283 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
35284 *PHKT(1,8+IIGLU1+IIGLU2)**2)
35285 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
35286 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
35287 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
35288 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
35289 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
35290 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
35291 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
35292 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
35293 IDHKT(9+IIGLU1+IIGLU2) =88888
35294 ISTHKT(9+IIGLU1+IIGLU2) =96
35295 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
35296 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
35297 JDAHKT(1,9+IIGLU1+IIGLU2)=0
35298 JDAHKT(2,9+IIGLU1+IIGLU2)=0
35299 PHKT(1,9+IIGLU1+IIGLU2)
35300 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
35301 PHKT(2,9+IIGLU1+IIGLU2)
35302 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
35303 PHKT(3,9+IIGLU1+IIGLU2)
35304 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
35305 PHKT(4,9+IIGLU1+IIGLU2)
35306 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
35307 PHKT(5,9+IIGLU1+IIGLU2)
35308 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
35309 * PHKT(2,9+IIGLU1+IIGLU2)**2
35310 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
35312 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
35313 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
35314 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
35315 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35316 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35317 & JMOHKT(1,IIG),JMOHKT(2,IIG),
35319 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35321 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
35322 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
35323 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
35324 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
35325 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
35326 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
35327 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
35328 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
35332 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
35333 ELSEIF(IPIP.EQ.2)THEN
35334 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
35336 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
35342 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
35343 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
35344 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
35345 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
35346 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
35347 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
35348 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
35349 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
35352 IGCOUN=9+IIGLU1+IIGLU2
35357 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35358 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35359 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35361 C USQBS-1 diagram (split projectile diquark)
35363 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35366 PARAMETER ( LINP = 5 ,
35372 PARAMETER (NMXHKK=200000)
35374 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35375 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35376 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35377 * extended event history
35378 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35379 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35381 * Lorentz-parameters of the current interaction
35382 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35383 & UMO,PPCM,EPROJ,PPROJ
35384 * diquark-breaking mechanism
35385 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35388 PARAMETER (NTMHKK= 300)
35389 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35390 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35393 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35396 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35397 COMMON /EVFLAG/ NUMEV
35399 C USQBS-1 diagram (split projectile diquark)
35401 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
35402 C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
35404 C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
35405 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
35407 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35408 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35409 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35411 C Put new chains into COMMON /HKKTMP/
35416 C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
35420 C IF(NUMEV.EQ.-324)THEN
35421 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35422 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
35423 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35424 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
35429 C determine x-values of NC1P diquark
35430 XDIQP=PHKK(4,NC1P)*2.D0/UMO
35431 XVQT=PHKK(4,NC1T)*2.D0/UMO
35433 C determine x-values of sea quark pair
35439 IF(ICOU.GE.500)THEN
35442 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
35446 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
35451 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35452 IF (IPIP.EQ.1) THEN
35453 XQMAX = XDIQP/2.0D0
35454 XAQMAX = 2.D0*XVQT/3.0D0
35456 XQMAX = 2.D0*XVQT/3.0D0
35457 XAQMAX = XDIQP/2.0D0
35459 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35461 C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
35463 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35466 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35471 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
35472 ELSEIF(IPIP.EQ.2)THEN
35473 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
35476 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
35477 * XDIQP,XVQT,XSQ,XSAQ
35480 C subtract xsq,xsaq from NC1P diquark and NC1T quark
35486 ELSEIF(IPIP.EQ.2)THEN
35491 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
35493 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
35498 IF(IVTHR.EQ.10)THEN
35501 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
35506 XVTHR=XVTHRO/(201-IVTHR)
35509 IF(XVTHR.GT.0.66D0*XDIQP)THEN
35512 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ',
35517 IF(DT_RNDM(V).LT.0.5D0)THEN
35518 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
35521 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
35525 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
35528 C Prepare 4 momenta of new chains and chain ends
35530 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35531 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35533 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35534 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35535 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35541 ELSEIF(IPIP.EQ.2)THEN
35551 JDAHKT(1,1)=3+IIGLU1
35553 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35554 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
35555 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
35556 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
35557 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
35558 C PHKT(5,1) =PHKK(5,NC1P)
35559 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35561 IF(XMIST.GE.0.D0)THEN
35562 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35565 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35568 VHKT(1,1) =VHKK(1,NC1P)
35569 VHKT(2,1) =VHKK(2,NC1P)
35570 VHKT(3,1) =VHKK(3,NC1P)
35571 VHKT(4,1) =VHKK(4,NC1P)
35572 WHKT(1,1) =WHKK(1,NC1P)
35573 WHKT(2,1) =WHKK(2,NC1P)
35574 WHKT(3,1) =WHKK(3,NC1P)
35575 WHKT(4,1) =WHKK(4,NC1P)
35576 C Add here IIGLU1 gluons to this chaina
35581 IF(IIGLU1.GE.1)THEN
35583 DO 61 IIG=2,2+IIGLU1-1
35585 IDHKT(IIG) =IDHKK(KKG)
35589 JDAHKT(1,IIG)=3+IIGLU1
35591 PHKT(1,IIG)=PHKK(1,KKG)
35592 PG1=PG1+ PHKT(1,IIG)
35593 PHKT(2,IIG)=PHKK(2,KKG)
35594 PG2=PG2+ PHKT(2,IIG)
35595 PHKT(3,IIG)=PHKK(3,KKG)
35596 PG3=PG3+ PHKT(3,IIG)
35597 PHKT(4,IIG)=PHKK(4,KKG)
35598 PG4=PG4+ PHKT(4,IIG)
35599 PHKT(5,IIG)=PHKK(5,KKG)
35600 VHKT(1,IIG) =VHKK(1,KKG)
35601 VHKT(2,IIG) =VHKK(2,KKG)
35602 VHKT(3,IIG) =VHKK(3,KKG)
35603 VHKT(4,IIG) =VHKK(4,KKG)
35604 WHKT(1,IIG) =WHKK(1,KKG)
35605 WHKT(2,IIG) =WHKK(2,KKG)
35606 WHKT(3,IIG) =WHKK(3,KKG)
35607 WHKT(4,IIG) =WHKK(4,KKG)
35610 IDHKT(2+IIGLU1) =IPP2
35611 ISTHKT(2+IIGLU1) =932
35612 JMOHKT(1,2+IIGLU1)=NC2T
35613 JMOHKT(2,2+IIGLU1)=0
35614 JDAHKT(1,2+IIGLU1)=3+IIGLU1
35615 JDAHKT(2,2+IIGLU1)=0
35616 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
35617 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
35618 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
35619 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
35620 C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
35621 XMIST=(PHKT(4,2+IIGLU1)**2-
35622 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35623 *PHKT(1,2+IIGLU1)**2)
35624 IF(XMIST.GT.0.D0)THEN
35625 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
35626 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35627 *PHKT(1,2+IIGLU1)**2)
35629 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35630 PHKT(5,2+IIGLU1)=0.D0
35632 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
35633 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
35634 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
35635 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
35636 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
35637 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
35638 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
35639 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
35640 IDHKT(3+IIGLU1) =88888
35641 ISTHKT(3+IIGLU1) =94
35642 JMOHKT(1,3+IIGLU1)=1
35643 JMOHKT(2,3+IIGLU1)=2+IIGLU1
35644 JDAHKT(1,3+IIGLU1)=0
35645 JDAHKT(2,3+IIGLU1)=0
35646 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35647 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35648 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35649 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35651 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35652 * -PHKT(3,3+IIGLU1)**2)
35653 IF(XMIST.GE.0.D0)THEN
35655 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35656 * -PHKT(3,3+IIGLU1)**2)
35658 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35662 C IF(NUMEV.EQ.-324)THEN
35663 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
35664 * JMOHKT(2,1),JDAHKT(1,1),
35665 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35666 DO 71 IIG=2,2+IIGLU1-1
35667 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35668 & JMOHKT(1,IIG),JMOHKT(2,IIG),
35670 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35672 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35673 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35674 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35675 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35676 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35677 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35681 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
35682 ELSEIF(IPIP.EQ.2)THEN
35683 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
35685 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35689 C WRITE(6,*)' MUSQBS1 jump back from chain 3'
35692 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
35693 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
35694 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
35695 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
35696 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
35697 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
35698 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
35699 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
35700 IDHKT(4+IIGLU1) =IP12
35701 ISTHKT(4+IIGLU1) =931
35702 JMOHKT(1,4+IIGLU1)=NC1P
35703 JMOHKT(2,4+IIGLU1)=0
35704 JDAHKT(1,4+IIGLU1)=6+IIGLU1
35705 JDAHKT(2,4+IIGLU1)=0
35706 C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35707 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
35708 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
35709 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
35710 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
35711 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
35712 XMIST =(PHKT(4,4+IIGLU1)**2-
35713 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35714 *PHKT(1,4+IIGLU1)**2)
35715 IF(XMIST.GT.0.D0)THEN
35716 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
35717 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35718 *PHKT(1,4+IIGLU1)**2)
35720 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35721 PHKT(5,4+IIGLU1)=0.D0
35723 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
35724 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
35725 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
35726 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
35727 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
35728 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
35729 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
35730 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
35732 IDHKT(5+IIGLU1) =-(ISAQ1-6)
35733 ELSEIF(IPIP.EQ.2)THEN
35734 IDHKT(5+IIGLU1) =ISAQ1
35736 ISTHKT(5+IIGLU1) =932
35737 JMOHKT(1,5+IIGLU1)=NC1T
35738 JMOHKT(2,5+IIGLU1)=0
35739 JDAHKT(1,5+IIGLU1)=6+IIGLU1
35740 JDAHKT(2,5+IIGLU1)=0
35741 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
35742 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
35743 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
35744 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
35745 C IF( PHKT(4,5).EQ.0.D0)THEN
35750 C PHKT(5,5) =PHKK(5,NC1T)
35751 XMIST=(PHKT(4,5+IIGLU1)**2-
35752 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
35753 *PHKT(1,5+IIGLU1)**2)
35754 IF(XMIST.GT.0.D0)THEN
35755 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
35756 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
35757 *PHKT(1,5+IIGLU1)**2)
35759 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35760 PHKT(5,5+IIGLU1)=0.D0
35762 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
35763 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
35764 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
35765 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
35766 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
35767 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
35768 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
35769 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
35770 IDHKT(6+IIGLU1) =88888
35771 ISTHKT(6+IIGLU1) =94
35772 JMOHKT(1,6+IIGLU1)=4+IIGLU1
35773 JMOHKT(2,6+IIGLU1)=5+IIGLU1
35774 JDAHKT(1,6+IIGLU1)=0
35775 JDAHKT(2,6+IIGLU1)=0
35776 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
35777 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
35778 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
35779 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
35781 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
35782 * -PHKT(3,6+IIGLU1)**2)
35783 IF(XMIST.GE.0.D0)THEN
35785 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
35786 * -PHKT(3,6+IIGLU1)**2)
35788 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35791 C IF(IPIP.EQ.3)THEN
35794 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
35795 ELSEIF(IPIP.EQ.2)THEN
35796 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
35798 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
35802 C WRITE(6,*)' MGSQBS1 jump back from chain 6',
35803 C * CHAMAL,PHKT(5,6+IIGLU1)
35807 C IF(NUMEV.EQ.-324)THEN
35808 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
35809 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
35810 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
35811 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
35812 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
35813 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
35814 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
35815 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
35816 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
35818 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
35819 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
35820 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
35821 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
35822 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
35823 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
35824 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
35825 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
35827 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
35828 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
35829 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
35830 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
35831 ELSEIF(IPIP.EQ.2)THEN
35832 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
35833 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
35834 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
35835 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
35836 C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
35838 ISTHKT(7+IIGLU1) =931
35839 JMOHKT(1,7+IIGLU1)=NC2P
35840 JMOHKT(2,7+IIGLU1)=0
35841 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
35842 JDAHKT(2,7+IIGLU1)=0
35843 C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35844 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
35845 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
35846 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
35847 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
35848 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
35849 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
35850 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
35852 C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
35857 C PHKT(5,7) =PHKK(5,NC2P)
35858 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
35859 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
35860 *PHKT(1,7+IIGLU1)**2)
35861 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
35862 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
35863 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
35864 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
35865 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
35866 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
35867 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
35868 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
35869 C Insert here the IIGLU2 gluons
35874 IF(IIGLU2.GE.1)THEN
35876 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35877 KKG=JJG+IIG-7-IIGLU1
35878 IDHKT(IIG) =IDHKK(KKG)
35882 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
35884 PHKT(1,IIG)=PHKK(1,KKG)
35885 PG1=PG1+ PHKT(1,IIG)
35886 PHKT(2,IIG)=PHKK(2,KKG)
35887 PG2=PG2+ PHKT(2,IIG)
35888 PHKT(3,IIG)=PHKK(3,KKG)
35889 PG3=PG3+ PHKT(3,IIG)
35890 PHKT(4,IIG)=PHKK(4,KKG)
35891 PG4=PG4+ PHKT(4,IIG)
35892 PHKT(5,IIG)=PHKK(5,KKG)
35893 VHKT(1,IIG) =VHKK(1,KKG)
35894 VHKT(2,IIG) =VHKK(2,KKG)
35895 VHKT(3,IIG) =VHKK(3,KKG)
35896 VHKT(4,IIG) =VHKK(4,KKG)
35897 WHKT(1,IIG) =WHKK(1,KKG)
35898 WHKT(2,IIG) =WHKK(2,KKG)
35899 WHKT(3,IIG) =WHKK(3,KKG)
35900 WHKT(4,IIG) =WHKK(4,KKG)
35903 IDHKT(8+IIGLU1+IIGLU2) =IP2
35904 ISTHKT(8+IIGLU1+IIGLU2) =932
35905 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
35906 JMOHKT(2,8+IIGLU1+IIGLU2)=0
35907 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
35908 JDAHKT(2,8+IIGLU1+IIGLU2)=0
35909 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
35910 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
35911 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
35912 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
35913 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
35914 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
35915 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
35916 *PHKT(1,8+IIGLU1+IIGLU2)**2)
35917 IF(XMIST.GT.0.D0)THEN
35918 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
35919 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
35920 *PHKT(1,8+IIGLU1+IIGLU2)**2)
35922 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35923 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
35925 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
35926 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
35927 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
35928 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
35929 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
35930 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
35931 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
35932 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
35933 IDHKT(9+IIGLU1+IIGLU2) =88888
35934 ISTHKT(9+IIGLU1+IIGLU2) =94
35935 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
35936 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
35937 JDAHKT(1,9+IIGLU1+IIGLU2)=0
35938 JDAHKT(2,9+IIGLU1+IIGLU2)=0
35939 PHKT(1,9+IIGLU1+IIGLU2)
35940 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
35941 PHKT(2,9+IIGLU1+IIGLU2)
35942 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
35943 PHKT(3,9+IIGLU1+IIGLU2)
35944 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
35945 PHKT(4,9+IIGLU1+IIGLU2)
35946 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
35948 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
35949 * -PHKT(2,9+IIGLU1+IIGLU2)**2
35950 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
35951 IF(XMIST.GE.0.D0)THEN
35952 PHKT(5,9+IIGLU1+IIGLU2)
35953 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
35954 * -PHKT(2,9+IIGLU1+IIGLU2)**2
35955 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
35957 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35961 C IF(NUMEV.EQ.-324)THEN
35962 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
35963 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
35964 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
35965 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35966 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35967 & JMOHKT(1,IIG),JMOHKT(2,IIG),
35969 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35971 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
35972 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
35973 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
35974 *JDAHKT(1,8+IIGLU1+IIGLU2),
35975 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
35976 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
35977 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
35978 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
35979 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
35983 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
35984 ELSEIF(IPIP.EQ.2)THEN
35985 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
35987 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
35991 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
35992 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
35995 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
35996 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
35997 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
35998 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
35999 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36000 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36001 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36002 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36005 IGCOUN=9+IIGLU1+IIGLU2
36009 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36010 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36011 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
36013 C GSQBS-1 diagram (split projectile diquark)
36015 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36018 PARAMETER ( LINP = 5 ,
36024 PARAMETER (NMXHKK=200000)
36026 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36027 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36028 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36029 * extended event history
36030 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36031 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36033 * Lorentz-parameters of the current interaction
36034 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36035 & UMO,PPCM,EPROJ,PPROJ
36036 * diquark-breaking mechanism
36037 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36040 PARAMETER (NTMHKK= 300)
36041 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36042 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36045 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36048 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36050 C GSQBS-1 diagram (split projectile diquark)
36053 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
36054 C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
36056 C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
36057 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
36059 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
36060 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
36061 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
36063 C Put new chains into COMMON /HKKTMP/
36068 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36070 NNNC1=IDHKK(NC1)/1000
36071 MMMC1=IDHKK(NC1)-NNNC1*1000
36073 NNNC2=IDHKK(NC2)/1000
36074 MMMC2=IDHKK(NC2)-NNNC2*1000
36078 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36079 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
36080 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36081 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
36086 C determine x-values of NC1P diquark
36087 XDIQP=PHKK(4,NC1P)*2.D0/UMO
36088 XVQT=PHKK(4,NC1T)*2.D0/UMO
36090 C determine x-values of sea quark pair
36096 IF(ICOU.GE.500)THEN
36099 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
36103 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
36108 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36109 IF (IPIP.EQ.1) THEN
36110 XQMAX = XDIQP/2.0D0
36111 XAQMAX = 2.D0*XVQT/3.0D0
36113 XQMAX = 2.D0*XVQT/3.0D0
36114 XAQMAX = XDIQP/2.0D0
36116 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36118 C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
36121 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36124 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36129 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
36130 ELSEIF(IPIP.EQ.2)THEN
36131 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
36134 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
36135 * XDIQP,XVQT,XSQ,XSAQ
36138 C subtract xsq,xsaq from NC1P diquark and NC1T quark
36144 C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
36147 ELSEIF(IPIP.EQ.2)THEN
36152 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
36154 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
36159 IF(IVTHR.EQ.10)THEN
36162 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
36167 XVTHR=XVTHRO/(201-IVTHR)
36170 IF(XVTHR.GT.0.66D0*XDIQP)THEN
36174 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ',
36179 IF(DT_RNDM(V).LT.0.5D0)THEN
36180 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
36183 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
36187 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
36188 * XVTHR,XDIQP,XVPQI,XVPQII
36191 C Prepare 4 momenta of new chains and chain ends
36193 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36194 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36196 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
36197 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
36198 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
36204 ELSEIF(IPIP.EQ.2)THEN
36211 C IDHKT(2) =1000*IPP21+100*IPP22+1
36215 IDHKT(4+IIGLU1) =IP12
36216 ISTHKT(4+IIGLU1) =921
36217 JMOHKT(1,4+IIGLU1)=NC1P
36218 JMOHKT(2,4+IIGLU1)=0
36219 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36220 JDAHKT(2,4+IIGLU1)=0
36222 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
36223 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
36225 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
36226 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
36227 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
36228 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
36229 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36230 XXMIST=(PHKT(4,4+IIGLU1)**2-
36231 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36232 * PHKT(1,4+IIGLU1)**2)
36233 IF(XXMIST.GT.0.D0)THEN
36234 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36236 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
36238 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36240 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36241 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36242 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36243 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36244 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36245 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36246 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36247 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36249 IDHKT(5+IIGLU1) =-(ISAQ1-6)
36250 ELSEIF(IPIP.EQ.2)THEN
36251 IDHKT(5+IIGLU1) =ISAQ1
36253 ISTHKT(5+IIGLU1) =922
36254 JMOHKT(1,5+IIGLU1)=NC1T
36255 JMOHKT(2,5+IIGLU1)=0
36256 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36257 JDAHKT(2,5+IIGLU1)=0
36259 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
36260 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
36262 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
36263 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
36264 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
36265 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
36266 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36267 XMIST=(PHKT(4,5+IIGLU1)**2-
36268 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36269 *PHKT(1,5+IIGLU1)**2)
36270 IF(XMIST.GT.0.D0)THEN
36271 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
36272 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36273 *PHKT(1,5+IIGLU1)**2)
36275 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36276 PHKT(5,5+IIGLU1)=0.D0
36278 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36279 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36280 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36281 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36282 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36283 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36284 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36285 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36286 IDHKT(6+IIGLU1) =88888
36287 C IDHKT(6) =1000*NNNC1+MMMC1
36288 ISTHKT(6+IIGLU1) =93
36290 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36291 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36292 JDAHKT(1,6+IIGLU1)=0
36293 JDAHKT(2,6+IIGLU1)=0
36294 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36295 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36296 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36297 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36299 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36300 * -PHKT(3,6+IIGLU1)**2)
36303 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
36304 ELSEIF(IPIP.EQ.2)THEN
36305 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
36307 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36308 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36309 C we drop chain 6 and give the energy to chain 3
36310 IDHKT(6+IIGLU1)=33888
36312 C WRITE(6,*)' drop chain 6 xgive=1'
36314 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
36315 C we drop chain 6 and give the energy to chain 3
36316 C and change KK11 to IDHKT(4)
36317 IDHKT(6+IIGLU1)=33888
36319 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
36320 KK11=IDHKT(4+IIGLU1)
36322 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
36323 C we drop chain 6 and give the energy to chain 3
36324 C and change KK21 to IDHKT(4)
36325 C IDHKT(2) =1000*IPP21+100*IPP22+1
36326 IDHKT(6+IIGLU1)=33888
36328 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
36329 KK21=IDHKT(4+IIGLU1)
36331 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
36332 C we drop chain 6 and give the energy to chain 3
36333 C and change KK22 to IDHKT(4)
36334 C IDHKT(2) =1000*IPP21+100*IPP22+1
36335 IDHKT(6+IIGLU1)=33888
36337 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
36338 KK22=IDHKT(4+IIGLU1)
36344 C WRITE(6,*)' MGSQBS1 jump back from chain 6'
36349 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36350 * JMOHKT(1,4+IIGLU1),
36351 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36352 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36353 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36354 * JMOHKT(1,5+IIGLU1),
36355 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36356 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36357 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36358 * JMOHKT(1,6+IIGLU1),
36359 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36360 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36362 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36363 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36364 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36365 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36366 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36367 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36368 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36369 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36375 JDAHKT(1,1)=3+IIGLU1
36377 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
36378 C * +0.5D0*PHKK(1,NC2P)
36379 *+XGIVE*PHKT(1,4+IIGLU1)
36380 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
36381 C * +0.5D0*PHKK(2,NC2P)
36382 *+XGIVE*PHKT(2,4+IIGLU1)
36383 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
36384 C * +0.5D0*PHKK(3,NC2P)
36385 *+XGIVE*PHKT(3,4+IIGLU1)
36386 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
36387 C * +0.5D0*PHKK(4,NC2P)
36388 *+XGIVE*PHKT(4,4+IIGLU1)
36389 C PHKT(5,1) =PHKK(5,NC1P)
36390 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36392 IF(XMIST.GE.0.D0)THEN
36393 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36396 C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
36399 VHKT(1,1) =VHKK(1,NC1P)
36400 VHKT(2,1) =VHKK(2,NC1P)
36401 VHKT(3,1) =VHKK(3,NC1P)
36402 VHKT(4,1) =VHKK(4,NC1P)
36403 WHKT(1,1) =WHKK(1,NC1P)
36404 WHKT(2,1) =WHKK(2,NC1P)
36405 WHKT(3,1) =WHKK(3,NC1P)
36406 WHKT(4,1) =WHKK(4,NC1P)
36407 C Add here IIGLU1 gluons to this chaina
36412 IF(IIGLU1.GE.1)THEN
36414 DO 61 IIG=2,2+IIGLU1-1
36416 IDHKT(IIG) =IDHKK(KKG)
36420 JDAHKT(1,IIG)=3+IIGLU1
36422 PHKT(1,IIG)=PHKK(1,KKG)
36423 PG1=PG1+ PHKT(1,IIG)
36424 PHKT(2,IIG)=PHKK(2,KKG)
36425 PG2=PG2+ PHKT(2,IIG)
36426 PHKT(3,IIG)=PHKK(3,KKG)
36427 PG3=PG3+ PHKT(3,IIG)
36428 PHKT(4,IIG)=PHKK(4,KKG)
36429 PG4=PG4+ PHKT(4,IIG)
36430 PHKT(5,IIG)=PHKK(5,KKG)
36431 VHKT(1,IIG) =VHKK(1,KKG)
36432 VHKT(2,IIG) =VHKK(2,KKG)
36433 VHKT(3,IIG) =VHKK(3,KKG)
36434 VHKT(4,IIG) =VHKK(4,KKG)
36435 WHKT(1,IIG) =WHKK(1,KKG)
36436 WHKT(2,IIG) =WHKK(2,KKG)
36437 WHKT(3,IIG) =WHKK(3,KKG)
36438 WHKT(4,IIG) =WHKK(4,KKG)
36441 C IDHKT(2) =1000*IPP21+100*IPP22+1
36443 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
36444 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
36445 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
36446 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
36447 ELSEIF(IPIP.EQ.2)THEN
36448 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
36449 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
36450 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
36451 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
36453 ISTHKT(2+IIGLU1) =922
36454 JMOHKT(1,2+IIGLU1)=NC2T
36455 JMOHKT(2,2+IIGLU1)=0
36456 JDAHKT(1,2+IIGLU1)=3+IIGLU1
36457 JDAHKT(2,2+IIGLU1)=0
36458 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
36459 *+XGIVE*PHKT(1,5+IIGLU1)
36460 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
36461 *+XGIVE*PHKT(2,5+IIGLU1)
36462 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
36463 *+XGIVE*PHKT(3,5+IIGLU1)
36464 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
36465 *+XGIVE*PHKT(4,5+IIGLU1)
36466 C PHKT(5,2) =PHKK(5,NC2T)
36467 XMIST=(PHKT(4,2+IIGLU1)**2-
36468 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36469 *PHKT(1,2+IIGLU1)**2)
36470 IF(XMIST.GT.0.D0)THEN
36471 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
36472 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36473 *PHKT(1,2+IIGLU1)**2)
36475 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
36476 PHKT(5,2+IIGLU1)=0.D0
36478 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
36479 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
36480 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
36481 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
36482 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
36483 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
36484 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
36485 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
36486 IDHKT(3+IIGLU1) =88888
36487 C IDHKT(3) =1000*NNNC1+MMMC1+10
36488 ISTHKT(3+IIGLU1) =93
36490 JMOHKT(1,3+IIGLU1)=1
36491 JMOHKT(2,3+IIGLU1)=2+IIGLU1
36492 JDAHKT(1,3+IIGLU1)=0
36493 JDAHKT(2,3+IIGLU1)=0
36494 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36495 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36496 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36497 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36499 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36500 * -PHKT(3,3+IIGLU1)**2)
36502 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36504 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36505 DO 71 IIG=2,2+IIGLU1-1
36506 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36507 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36509 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36511 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
36512 & IDHKT(2),JMOHKT(1,2+IIGLU1),
36513 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36514 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36515 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36516 * JMOHKT(1,3+IIGLU1),
36517 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36518 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36522 C IF(IPIP.EQ.1)THEN
36523 C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
36524 C ELSEIF(IPIP.EQ.2)THEN
36525 C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
36528 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
36529 ELSEIF(IPIP.EQ.2)THEN
36530 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
36533 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36537 C WRITE(6,*)' MGSQBS1 jump back from chain 3'
36540 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
36541 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
36542 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
36543 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
36544 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
36545 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
36546 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
36547 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
36549 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
36550 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
36551 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
36552 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
36553 ELSEIF(IPIP.EQ.2)THEN
36554 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
36555 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
36556 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
36557 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
36558 C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
36560 ISTHKT(7+IIGLU1) =921
36561 JMOHKT(1,7+IIGLU1)=NC2P
36562 JMOHKT(2,7+IIGLU1)=0
36563 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36564 JDAHKT(2,7+IIGLU1)=0
36565 C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
36566 C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
36567 C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
36568 C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
36570 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
36571 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
36573 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
36574 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
36575 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
36576 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
36577 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
36578 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
36579 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
36581 C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
36586 C PHKT(5,7) =PHKK(5,NC2P)
36587 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
36588 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36589 *PHKT(1,7+IIGLU1)**2)
36590 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
36591 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
36592 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
36593 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
36594 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
36595 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
36596 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
36597 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36598 C Insert here the IIGLU2 gluons
36603 IF(IIGLU2.GE.1)THEN
36605 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36606 KKG=JJG+IIG-7-IIGLU1
36607 IDHKT(IIG) =IDHKK(KKG)
36611 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36613 PHKT(1,IIG)=PHKK(1,KKG)
36614 PG1=PG1+ PHKT(1,IIG)
36615 PHKT(2,IIG)=PHKK(2,KKG)
36616 PG2=PG2+ PHKT(2,IIG)
36617 PHKT(3,IIG)=PHKK(3,KKG)
36618 PG3=PG3+ PHKT(3,IIG)
36619 PHKT(4,IIG)=PHKK(4,KKG)
36620 PG4=PG4+ PHKT(4,IIG)
36621 PHKT(5,IIG)=PHKK(5,KKG)
36622 VHKT(1,IIG) =VHKK(1,KKG)
36623 VHKT(2,IIG) =VHKK(2,KKG)
36624 VHKT(3,IIG) =VHKK(3,KKG)
36625 VHKT(4,IIG) =VHKK(4,KKG)
36626 WHKT(1,IIG) =WHKK(1,KKG)
36627 WHKT(2,IIG) =WHKK(2,KKG)
36628 WHKT(3,IIG) =WHKK(3,KKG)
36629 WHKT(4,IIG) =WHKK(4,KKG)
36632 IDHKT(8+IIGLU1+IIGLU2) =IP2
36633 ISTHKT(8+IIGLU1+IIGLU2) =922
36634 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
36635 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36636 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36637 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36639 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
36640 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
36642 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
36643 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
36644 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
36645 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
36646 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
36647 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
36648 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36649 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36650 IF(XMIST.GT.0.D0)THEN
36651 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36652 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36653 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36655 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
36656 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
36658 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
36659 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
36660 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
36661 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
36662 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
36663 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
36664 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
36665 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
36666 IDHKT(9+IIGLU1+IIGLU2) =88888
36667 C IDHKT(9) =1000*NNNC2+MMMC2+10
36668 ISTHKT(9+IIGLU1+IIGLU2) =93
36670 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36671 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36672 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36673 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36674 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
36675 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
36676 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
36677 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
36678 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
36679 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
36680 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
36681 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
36682 PHKT(5,9+IIGLU1+IIGLU2)
36683 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36684 * PHKT(2,9+IIGLU1+IIGLU2)**2
36685 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36687 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36688 * JMOHKT(1,7+IIGLU1),
36689 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36690 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36691 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36692 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36693 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36695 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36697 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36698 * IDHKT(8+IIGLU1+IIGLU2),
36699 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
36700 * JDAHKT(1,8+IIGLU1+IIGLU2),
36701 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36702 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36703 * IDHKT(9+IIGLU1+IIGLU2),
36704 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
36705 * JDAHKT(1,9+IIGLU1+IIGLU2),
36706 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36710 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36711 ELSEIF(IPIP.EQ.2)THEN
36712 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36714 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36718 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
36719 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36722 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36723 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36724 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36725 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36726 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36727 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36728 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36729 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36731 IGCOUN=9+IIGLU1+IIGLU2
36736 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36738 SUBROUTINE HKKHKT(I,J)
36739 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36744 PARAMETER (NMXHKK=200000)
36746 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36747 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36748 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36749 * extended event history
36750 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36751 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36754 PARAMETER (NTMHKK= 300)
36755 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36756 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36759 ISTHKK(I) =ISTHKT(J)
36761 C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
36762 IF(IDHKK(I).EQ.88888)THEN
36765 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
36766 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
36768 JMOHKK(1,I)=JMOHKT(1,J)
36769 JMOHKK(2,I)=JMOHKT(2,J)
36771 JDAHKK(1,I)=JDAHKT(1,J)
36772 JDAHKK(2,I)=JDAHKT(2,J)
36773 C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
36775 C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
36778 IF(JDAHKT(1,J).GT.0)THEN
36779 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
36781 PHKK(1,I) =PHKT(1,J)
36782 PHKK(2,I) =PHKT(2,J)
36783 PHKK(3,I) =PHKT(3,J)
36784 PHKK(4,I) =PHKT(4,J)
36785 PHKK(5,I) =PHKT(5,J)
36786 VHKK(1,I) =VHKT(1,J)
36787 VHKK(2,I) =VHKT(2,J)
36788 VHKK(3,I) =VHKT(3,J)
36789 VHKK(4,I) =VHKT(4,J)
36790 WHKK(1,I) =WHKT(1,J)
36791 WHKK(2,I) =WHKT(2,J)
36792 WHKK(3,I) =WHKT(3,J)
36793 WHKK(4,I) =WHKT(4,J)
36797 *===dbreak=============================================================*
36799 CDECK ID>, DT_DBREAK
36800 SUBROUTINE DT_DBREAK(MODE)
36802 ************************************************************************
36803 * This is the steering subroutine for the different diquark breaking *
36806 * MODE = 1 breaking of projectile diquark in qq-q chain using *
36807 * a sea quark (q-qq chain) of the same projectile *
36808 * = 2 breaking of target diquark in q-qq chain using *
36809 * a sea quark (qq-q chain) of the same target *
36810 * = 3 breaking of projectile diquark in qq-q chain using *
36811 * a sea quark (q-aq chain) of the same projectile *
36812 * = 4 breaking of target diquark in q-qq chain using *
36813 * a sea quark (aq-q chain) of the same target *
36814 * = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
36815 * a sea anti-quark (aq-aqaq chain) of the same projectile *
36816 * = 6 breaking of target anti-diquark in aq-aqaq chain using *
36817 * a sea anti-quark (aqaq-aq chain) of the same target *
36818 * = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
36819 * a sea anti-quark (aq-q chain) of the same projectile *
36820 * = 8 breaking of target anti-diquark in aq-aqaq chain using *
36821 * a sea anti-quark (q-aq chain) of the same target *
36823 * Original version by J. Ranft. *
36824 * This version dated 17.5.00 is written by S. Roesler. *
36825 ************************************************************************
36827 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36830 PARAMETER ( LINP = 5 ,
36836 PARAMETER (NMXHKK=200000)
36838 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36839 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36840 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36841 * extended event history
36842 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36843 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36845 * flags for input different options
36846 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
36847 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
36848 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
36849 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
36850 PARAMETER (MAXCHN=10000)
36851 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
36852 * diquark-breaking mechanism
36853 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36854 * flags for particle decays
36855 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
36856 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
36857 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
36860 * chain identifiers
36861 * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
36862 * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
36863 DIMENSION IDCHN1(8),IDCHN2(8)
36864 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
36865 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
36867 * parton identifiers
36868 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
36869 * +-51/52 = unitarity-sea, +-61/62 = gluons )
36870 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
36871 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
36872 & 31, 31, 31, 31, 31, 31, 31, 31,
36873 & 41, 41, 41, 41, 51, 51, 51, 51/
36874 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
36875 & 32, 32, 32, 32, 32, 32, 32, 32,
36876 & 42, 42, 42, 42, 52, 52, 52, 52/
36877 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
36878 & 51, 31, 41, 41, 31, 31, 31, 31,
36879 & 0, 41, 51, 51, 51, 51, 51, 51/
36880 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
36881 & 32, 52, 42, 42, 32, 32, 32, 32,
36882 & 42, 0, 52, 52, 52, 52, 52, 52/
36884 IF (NCHAIN.LE.0) RETURN
36887 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
36888 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
36889 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
36891 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
36892 & (IS1P.EQ.ISP1P(MODE,3)))
36894 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
36895 & (IS1T.EQ.ISP1T(MODE,3)))
36899 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
36900 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
36901 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
36903 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
36904 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
36906 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
36907 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
36909 * find mother nucleons of the diquark to be splitted and of the
36910 * sea-quark and reject this combination if it is not the same
36911 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
36912 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
36917 IDXMO1 = JMOHKK(IANCES,IDX1)
36919 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
36920 & (JMOHKK(2,IDXMO1).NE.0)) THEN
36925 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
36926 IDXMO1 = JMOHKK(IANC,IDXMO1)
36929 IDXMO2 = JMOHKK(IANCES,IDX2)
36931 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
36932 & (JMOHKK(2,IDXMO2).NE.0)) THEN
36937 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
36938 IDXMO2 = JMOHKK(IANC,IDXMO2)
36941 IF (IDXMO1.NE.IDXMO2) GOTO 2
36942 * quark content of projectile parton
36943 IP1 = IDHKK(JMOHKK(1,IDX1))
36945 IP12 = (IP1-1000*IP11)/100
36946 IP2 = IDHKK(JMOHKK(2,IDX1))
36948 IP22 = (IP2-1000*IP21)/100
36949 * quark content of target parton
36950 IT1 = IDHKK(JMOHKK(1,IDX2))
36952 IT12 = (IT1-1000*IT11)/100
36953 IT2 = IDHKK(JMOHKK(2,IDX2))
36955 IT22 = (IT2-1000*IT21)/100
36956 * split diquark and form new chains
36957 IF (MODE.EQ.1) THEN
36958 IF (IT1.EQ.4) GOTO 2
36959 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36960 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36961 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
36962 ELSEIF (MODE.EQ.2) THEN
36963 IF (IT2.EQ.4) GOTO 2
36964 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36965 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36966 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
36967 ELSEIF (MODE.EQ.3) THEN
36968 IF (IT1.EQ.4) GOTO 2
36969 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36970 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36971 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
36972 ELSEIF (MODE.EQ.4) THEN
36973 IF (IT2.EQ.4) GOTO 2
36974 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36975 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36976 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
36977 ELSEIF (MODE.EQ.5) THEN
36978 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36979 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36980 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
36981 ELSEIF (MODE.EQ.6) THEN
36982 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36983 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36984 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
36985 ELSEIF (MODE.EQ.7) THEN
36986 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36987 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36988 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
36989 ELSEIF (MODE.EQ.8) THEN
36990 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
36991 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
36992 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
36994 IF (IREJ.GE.1) THEN
36995 if ((ipq.lt.0).or.(ipq.ge.4))
36996 & write(LOUT,*) 'ipq !!!',ipq,mode
36997 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
36998 * accept or reject new chains corresponding to PDBSEA
37000 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
37001 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
37002 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
37003 ELSEIF (IPQ.EQ.3) THEN
37004 ACC = DBRKA(3,MODE)
37005 REJ = DBRKR(3,MODE)
37007 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
37010 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
37011 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
37014 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
37017 * new chains have been accepted and are now copied into HKKEVT
37018 IF (IACC.EQ.1) THEN
37020 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
37021 & PHKK(3,IDX1),PHKK(4,IDX1),
37023 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
37024 & PHKK(3,IDX2),PHKK(4,IDX2),
37027 IDHKK(IDX1) = 99888
37028 IDHKK(IDX2) = 99888
37033 CALL HKKHKT(NHKK,K)
37034 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
37039 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
37044 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
37046 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
37058 *===cqpair=============================================================*
37060 CDECK ID>, DT_CQPAIR
37061 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
37063 ************************************************************************
37064 * This subroutine Creates a Quark-antiquark PAIR from the sea. *
37066 * XQMAX maxium energy fraction of quark (input) *
37067 * XAQMAX maxium energy fraction of antiquark (input) *
37068 * XQ energy fraction of quark (output) *
37069 * XAQ energy fraction of antiquark (output) *
37070 * IFLV quark flavour (- antiquark flavor) (output) *
37072 * This version dated 14.5.00 is written by S. Roesler. *
37073 ************************************************************************
37075 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37078 PARAMETER ( LINP = 5 ,
37082 * Lorentz-parameters of the current interaction
37083 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37084 & UMO,PPCM,EPROJ,PPROJ
37091 * sample quark flavour
37093 * set seasq here (the one from DTCHAI should be used in the future)
37095 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
37097 * sample energy fractions of sea pair
37098 * we first sample the energy fraction of a gluon and then split the gluon
37100 * maximum energy fraction of the gluon forced via input
37101 XGMAXI = XQMAX+XAQMAX
37102 * minimum energy fraction of the gluon
37103 XTHR1 = 4.0D0 /UMO**2
37104 XTHR2 = 0.54D0/UMO**1.5D0
37105 XGMIN = MAX(XTHR1,XTHR2)
37106 * maximum energy fraction of the gluon
37108 XGMAX = MIN(XGMAXI,XGMAX)
37109 IF (XGMIN.GE.XGMAX) THEN
37114 * sample energy fraction of the gluon
37118 IF (NLOOP.GE.50) THEN
37122 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
37123 EGLUON = XGLUON*UMO/2.0D0
37125 * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
37126 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
37129 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
37131 IF (RQ.LT.0.5D0) THEN
37138 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1